現状関数で求められる値をVBA化後、A列の時刻変更はVBAの何処を変更したらよいでしょうか？

現状A列　9：00～17：00
変更A列　8：00～18：00

➡関数（I2）
=SUMPRODUCT(($A$2:$A$5>=$F$2)*($A$2:$A$5<=$H$2)*($B$2:$E$5=I1))

➡こちらでご教授いただいたVBA記述
Option Explicit

Public Sub 時間別品目別個数算出()
Dim dicT As Object
Dim sh As Worksheet
Dim maxrow As Long
Dim maxcol As Long
Dim wrow As Long
Dim wcol As Long
Dim grow As Long
Dim gcol As Long
Dim key As String
Dim hh As Long
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set sh = ActiveSheet
maxrow = sh.Cells(Rows.Count, 1).End(xlUp).Row 'A列最終行を求める
maxcol = sh.Cells(1, Columns.Count).End(xlToLeft).Column '1行目の最終列を求める
sh.Range(sh.Cells(2, 9), sh.Cells(10, maxcol)).Value = "" '個数クリア
'品目記憶
For wcol = 9 To maxcol
dicT(sh.Cells(1, wcol).Value) = wcol
Next
'全行分繰り返す
For wrow = 2 To maxrow
hh = Hour(sh.Cells(wrow, "A").Value)
If hh < 9 Or hh > 17 Then
MsgBox ("時刻不正:" & sh.Cells(wrow, "A").Text)
Exit Sub
End If
'発注１～３分繰り返す
For wcol = 2 To 4
key = sh.Cells(wrow, wcol).Value
If key <> "" Then
If dicT.exists(key) = False Then
MsgBox ("品目不正:" & key)
Exit Sub
End If
'該当品目へ１加算
grow = hh - 7
gcol = dicT(key)
sh.Cells(grow, gcol).Value = sh.Cells(grow, gcol).Value + 1
End If
Next
Next
MsgBox ("完了")
End Sub

No.1 回答者： fujillin 回答日時： 2021/04/05 22:55

こんばんは

わからないVBAを使っていると、（発見しにくい）間違いが混入している場合や、ご質問のようにちょっとした修正に対してもお手上げ状態になってしまいます。
理解できる関数で実現できているのなら、そちらの方を採用なさった方が宜しそうに思われます。
（それなら、ご質問の内容も簡単に反映できるものと推測します。）

例えば、マクロのようにいちいち実行させなくても、関数であれば元データの変更に応じて自動的に結果に反映することも可能です。
ご質問文には前提条件が記載されていませんが、ご提示のマクロはF列は9：00～の決め打ちで、かつ、F1以降（1行目）にはあらかじめ、品目のリストアップがされているという条件があるものと推測します。
（マクロで処理するのなら、これらの時刻や項目セルの内容もマクロで抽出する方が宜しいのかもしれません）


とは言え、とりあえずご質問内容の修正のヒントを以下に。

＞sh.Range(sh.Cells(2, 9), sh.Cells(10, maxcol)).Value = "" '個数クリア
対象範囲をクリアしていますが、数値の範囲を2～10行目と決め打ちで処理していますので、これを必要行数に変更する必要があります。
ご質問文には、現状が
＞9：00～17：00
とありますが、9：00～16：59だと8行になるので、現状の実際は9：00～17：59の9行ということなのでしょうか？（私にはわかりませんけれど）

＞If hh < 9 Or hh > 17 Then
A列の時刻部分の範囲チェックをしています。（9～17時の範囲）
この範囲にないとエラー扱いとしているので、チェック範囲を修正しましょう。

＞grow = hh - 7
加算する行数を「時刻-7」の固定で計算しています。（9時が2行目ということ）
この部分を対応する行になるように修正する必要があります。

ざっと見ただけですが、多分、ほぼこれでいけるのではないでしょうか？

※ なお、ご質問には関係はありませんが、全体に sh = ActiveSheet でシートを設定して、そのシートに対する処理として記述されていますが、当該シートだけで処理が完結しているので省略しても問題はなさそうに思われます。（別に、あっても問題はありませんけれど）

この回答へのお礼

お考えいただきありがとうございます。
＞sh.Range(sh.Cells(2, 9), sh.Cells(12, maxcol)).Value = ""
＞If hh < 8 Or hh > 18 Then
＞grow = hh - 9
へ変更してみましたが下記で止まります？
＞sh.Cells(grow, gcol).Value = sh.Cells(grow, gcol).Value + 1

お礼日時：2021/04/06 01:31

No.2 ベストアンサー 回答者： めぐみん_ 回答日時： 2021/04/06 04:58

横から失礼いたします。

さすがにベテラン様のコードは難解ですね。
初級レベルなジジィには解読困難です。

＞＞grow = hh - 9

これですと『８：００～９：５９』って行が -1 や 0 になりますけど、Excelにはそのような行は存在しません。
『８：００』＝ 8 を 2 にとのアドバイスを受けていらっしゃるのですから、

＞grow = hh - 9

は

grow = hh - 6

ではないかなと。

あと『品目』については転記先に事前に並べてある状態なのでしょうか？
それとも『数式』の為に敢えて行なっているだけで実際には固定化されない分都度転記してくれた方が宜しいのでしょうか？

この回答へのお礼

毎度毎度ありがとうございます。
-6の仕組みを勉強します。

お礼日時：2021/04/06 13:45

No.3 回答者： fujillin 回答日時： 2021/04/06 08:15

No1です

＞＞grow = hh - 9
＞へ変更してみましたが下記で止まります？
すでにご指摘がでていますが、
No1に
「加算する行数を「時刻-7」の固定で計算しています。（9時が2行目ということ）」
と記したつもりですけれど、その修正だと、8時が-1行目（9時は0行目）ということになり、その行に対して実行しようとしてエラーになります。

・・・ということになるのを想定して、
私のお勧めは、No1にも記しましたように、あくまでも「理解できる範囲内であろう、関数を利用すること」と記したつもりなのですけれど・・・

この回答へのお礼

ありがとうございます。2日間悩んだ末こちらでお聞きしました。

お礼日時：2021/04/06 13:43

No.4 回答者： tatsumaru77 回答日時： 2021/04/06 11:57

以下のようにしてください。

変更点は、いかの３個所です。
① sh.Range(sh.Cells(2, 9), sh.Cells(12, maxcol)).Value = "" '個数クリア
② If hh < 8 Or hh > 18 Then
③ grow = hh - 6


Public Sub 時間別品目別個数算出()
Dim dicT As Object
Dim sh As Worksheet
Dim maxrow As Long
Dim maxcol As Long
Dim wrow As Long
Dim wcol As Long
Dim grow As Long
Dim gcol As Long
Dim key As String
Dim hh As Long
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set sh = ActiveSheet
maxrow = sh.Cells(Rows.Count, 1).End(xlUp).Row 'A列最終行を求める
maxcol = sh.Cells(1, Columns.Count).End(xlToLeft).Column '1行目の最終列を求める
sh.Range(sh.Cells(2, 9), sh.Cells(12, maxcol)).Value = "" '個数クリア
'品目記憶
For wcol = 9 To maxcol
dicT(sh.Cells(1, wcol).Value) = wcol
Next
'全行分繰り返す
For wrow = 2 To maxrow
hh = Hour(sh.Cells(wrow, "A").Value)
If hh < 8 Or hh > 18 Then
MsgBox ("時刻不正:" & sh.Cells(wrow, "A").Text)
Exit Sub
End If
'発注１～３分繰り返す
For wcol = 2 To 4
key = sh.Cells(wrow, wcol).Value
If key <> "" Then
If dicT.exists(key) = False Then
MsgBox ("品目不正:" & key)
Exit Sub
End If
'該当品目へ１加算
grow = hh - 6
gcol = dicT(key)
sh.Cells(grow, gcol).Value = sh.Cells(grow, gcol).Value + 1
End If
Next
Next
MsgBox ("完了")
End Sub

この回答へのお礼

ありがとうございます。
-6の仕組みを勉強させていただきます。

お礼日時：2021/04/06 13:46

No.5 回答者： めぐみん_ 回答日時： 2021/04/07 17:12

※この回答は、“締め切られた質問への回答追加”として、2021/04/06 15:04 に回答者の方よりご依頼をいただき、教えて!gooによって代理投稿されたものです。

---
数式で入れたい場合の一例です。（ご参考になれば幸いです。）

Sub megu()
Dim r1 As Range, r2 As Range, r3 As Range
Dim st As String

st = "=SUMPRODUCT((HOUR(x)=HOUR($F2))*(y=I$1))"

Set r1 = Range("A2", Cells(Rows.Count, "A").End(xlUp))

Set r2 = Range("A1").CurrentRegion
Set r2 = r2.Offset(1, 1)
Set r2 = r2.Resize(r2.Rows.Count - 1, r2.Columns.Count - 1)

Set r3 = Intersect(Range("I1", Cells(1, Columns.Count)).EntireColumn, _
Range("I1").CurrentRegion.EntireColumn, Range("F1").CurrentRegion.EntireRow)
Set r3 = r3.Offset(1)
Set r3 = r3.Resize(r3.Rows.Count - 1)

st = Replace(st, "x", r1.Address)
st = Replace(st, "y", r2.Address)

With r3
.Formula = st
'.Value = .Value ' 値にしたい時は先頭の ' を消してください。
End With

Set r1 = Nothing
Set r2 = Nothing
Set r3 = Nothing

End Sub