| |
なお、Dictionary は
C列の記号の後に 試作品、製品、特別品別を区別する記号を付したもので、
辞書のキーに登録していけば、dicを3つ用意しなくても済みます。
Sub test61() '1つのdicで済ます
Dim n As Long
Dim y As Long, x As Long '整数型は特別な場合を除いて Long がよい
Dim i As Long, k As Long
Dim ss As String, sk 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 As Object
Set dic = CreateObject("Scripting.Dictionary")
ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
'◆まず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行
sk = ss & k 'C列記号＋製品種別番号
n = WorksheetFunction. _
RoundUp(c.Offset(k - 2, 2).Value, -2)
If Not dic.Exists(sk) Then 'keyが無ければ登録
dic(sk) = n 'その行の数値を登録
ElseIf dic(sk) < n Then 'すでにキーのあるとき
'この行のnがこれまでの最大値より大きければ
dic(sk) = n '最大値の更新
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(ss & k)
Next k
End If
End If
Next i
Next y
Next x
MsgBox "持ち上げが完了しました。" & vbCr _
& "掛け数の設定されている台は、手集計して下さい"
End Sub
|
|
kanabun
- 14/3/18(火) 19:40 -
