‘重複品番のうち、価格が同じはOKと判断する。 ‘配列に重複品番を格納 Dim Dic As Object, buf As String Dim Arr() As String: ReDim Arr(0) ‘Index 0で初期化 Dim sum下代 As Currency, ave下代 As Currency Dim rowNo As Long, i As Long, k As Long, m As Long Dim LastRow As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Worksheets(s1)
For i = 4 To LastRow
If .Range("A" & i) = "重複" Then
buf = .Range("N" & i).Value ''セルの値を変数bufに格納する
If Not Dic.Exists(buf) Then ''まだ登録されていなかったら…
Dic.Add buf, buf ''セルの値を連想配列に登録する
'Arrへの格納時に、添え字の数値指定ではなくUboundで最大要素に追加する。
Arr(UBound(Arr)) = .Range("N" & i).Value
'拡張
ReDim Preserve Arr(UBound(Arr) + 1)
End If
End If
Next i
'1つ余分に作ってしまうので削除
ReDim Preserve Arr(UBound(Arr) - 1)
MsgBox Dic.Count & "件の品番が重複しています。"
'重複品番の各品番ごとに下代の平均値を算出し、それに下代の金額が合致していたら問題ないと判定し、「重複」⇒「OK」に変更する
For i = 0 To Dic.Count - 1
sum下代 = 0
m = 0
For k = 4 To LastRow
'重複品番のある行数を取得
If .Range("N" & k).Value = Arr(i) Then
'下代(U列)の合計を算出
sum下代 = sum下代 + .Range("U" & k).Value
m = m + 1
End If
Next k
ave下代 = sum下代 / m
For k = 4 To LastRow
'重複品番のある行数を取得
If .Range("N" & k).Value = Arr(i) And .Range("U" & k).Value = ave下代 Then
.Range("A" & k).Value = "OK"
'背景色とフォントカラーを通常に戻す。
.Range("A" & k).Interior.Color = RGB(255, 255, 255)
.Range("A" & k).Font.Color = RGB(0, 0, 0)
.Range("Q" & k).Interior.Color = RGB(255, 255, 255)
.Range("R" & k).Interior.Color = RGB(255, 255, 255)
.Range("U" & k).Interior.Color = RGB(255, 255, 255)
End If
Next k
Next
MsgBox "重複品番については、下代の金額が合致していた場合、" & vbCrLf & "問題ないと判定しますので、A列を「OK」に変更いたします。"
End With
'-----検証----
Debug.Print "----"
For i = 0 To UBound(Arr)
Debug.Print Arr(i)
Next i
Debug.Print "----"
Set Dic = Nothing
参考文献
★動的配列:UBound