| |
▼初心者M さん：
C列の記号の出現回数をカウントする もうひとつ別の Dictionary を用意し
ここに出現回数をカウントしていくようにしてみました。
Sub test7() '品名 出現回数をカウント
Dim n 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
For k = 1 To 3 '記号のある行の-1行〜2行までの3行
n = WorksheetFunction. _
RoundUp(c.Offset(k - 2, 2).Value, -2)
If Not dic(k).Exists(ss) Then 'keyが無ければ登録
dic(k)(ss) = n 'その行の数値を登録
nc(ss) = 1
ElseIf dic(k)(ss) < n Then 'すでにキーのあるとき
'この行のnがこれまでの最大値より大きければ
dic(k)(ss) = n '最大値の更新
nc(ss) = nc(ss) + 1 '出現回数のカウント
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/19(水) 13:59 -
