| |
以下で試してみてください。
何かあれば、お願いします。
Sub test73() '品名 出現回数をカウント
Dim n As Long, p As Long
Dim y As Long, x As Long
Dim i As Long, k As Long
Dim ss As String
Dim c As Range
Const Y0 = 8, YY = 84, Ystp = 16 '縦方向 最初の行番・Loop回数・Step数
Const X0 = 3, XX = 27, Xstp = 3 '横方向 最初の列番・Loop回数・Step数
Dim dic(1 To 3) As Object
Set dic(1) = CreateObject("Scripting.Dictionary") '試作品グループ
Set dic(2) = CreateObject("Scripting.Dictionary") '製品グループ
Set dic(3) = CreateObject("Scripting.Dictionary") '特別品グループ
Dim nc As Object
Set nc = CreateObject("Scripting.Dictionary")
Dim NCMAX As Long
ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
NCMAX = [X1].Value
NCMAX = Val(InputBox$("最大出現回数", , NCMAX))
If NCMAX < 1 Then Exit Sub
'◆まずC列のキー別に、1段目、2段目、3段目別に、最大値を求める
For x = X0 To X0 + (XX - 1) * Xstp Step Xstp
For y = Y0 To Y0 + (YY - 1) * Ystp Step Ystp
For i = 2 To 8 Step 3 '[C8]セルを1行目として
Set c = Cells(y, x).Item(i, 1) '2,5,8行目
'ただし D列に数字が入っていたら
If WorksheetFunction.IsNumber(c(1, 2)) Then
'「何もしない」塗りつぶすだけ
c.Resize(, 2).Interior.Color = vbGreen
Else
ss = c.Value
If Len(ss) > 0 Then
nc(ss) = nc(ss) + 1 '◆出現回数のカウント
For k = 1 To 3 '記号のある行の-1行〜2行までの3行
p = c.Offset(k - 2, 2).Value2 'E列の数値
If p > 0& Then '空白でなかったら
n = WorksheetFunction.RoundUp(p, -2)
If Not dic(k).Exists(ss) Then 'keyが無ければ登録
dic(k)(ss) = n 'その行の数値を登録
ElseIf dic(k)(ss) < n Then 'すでにキーのあるとき
'この行のnがこれまでの最大値より大きければ
dic(k)(ss) = n '最大値の更新
End If
ElseIf Not dic(k).Exists(ss) Then
dic(k)(ss) = Empty
End If
Next k
End If
End If
Next i
Next y
Next x
'◆求まったキー別最大値で元表の数値列を更新
For x = X0 To X0 + (XX - 1) * Xstp Step Xstp
For y = Y0 To Y0 + (YY - 1) * Ystp Step Ystp
For i = 2 To 8 Step 3 '[C8]セルを1行目として
Set c = Cells(y, x).Item(i, 1) '2,5,8行目
'ただし D列に数字が入っていたら
If WorksheetFunction.IsNumber(c(1, 2)) Then
'「何もしない」
Else
ss = c.Value
If Len(ss) > 0 Then
For k = 1 To 3 '記号のある行の-1行〜2行までの3行
c.Offset(k - 2, 2).Value = dic(k)(ss)
Next k
If nc(ss) > NCMAX Then
c.Interior.Color = vbRed '制限数超過
End If
End If
End If
Next i
Next y
Next x
MsgBox "持ち上げが完了しました。" & vbCr _
& "掛け数の設定されている台は、手集計して下さい"
End Sub
|
|
kanabun
- 14/3/24(月) 11:40 -
