| |
▼ムーン さん 今日は。
これでできると思います。
Sub main()
Dim rngA As Range, r As Range
Dim Dic As Object
Dim dkey
'
Set rngA = ActiveSheet.Range("A1", Range("A65536").End(xlUp))
Set Dic = CreateObject("Scripting.Dictionary")
'
For Each r In rngA.Cells
dkey = r.Text & r.Offset(, 1).Text & r.Offset(, 2).Text
Dic.Item(dkey) = Dic.Item(dkey) + r.Offset(, 3).Text
Next
'
For Each dkey In Dic.keys()
For Each r In ActiveSheet.Range("A1", Range("A65536").End(xlUp))
If r.Text & r.Offset(, 1).Text & r.Offset(, 2).Text = dkey Then
r.Offset(, 4) = Dic.Item(dkey)
Exit For
End If
Next
Next
'
Set Dic = Nothing
Set rngA = Nothing
End Sub
|
|
kobasan
- 06/1/14(土) 16:20 -
