|
こんにちは
これで如何でしょうか?
(Sheet1の1行目は項目行とします。又、Sheet2はすべてのセルが空白である事)
Sub Test_Sum()
Dim Ws As Worksheet, C As Range, R As Range
Dim Fi As Range, Ad As String, Ma As Variant
Set Ws = Worksheets("Sheet2")
Application.ScreenUpdating = False
Ws.Cells.Clear
With Worksheets("Sheet1")
.Columns(1).AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
.Columns(2).AdvancedFilter xlFilterCopy, , Ws.Range("B1"), True
With Ws.Range("B2", Ws.Range("B65536").End(xlUp))
.Copy
Ws.Range("B1").PasteSpecial xlPasteAll, , , True
.Clear
Set R = .Offset(, -1)
End With
For Each C In R
Set Fi = .Columns(1).Find(C.Value, , xlValues, , xlWhole)
If Not Fi Is Nothing Then
Ad = Fi.Address
Do
Set Fi = .Columns(1).FindNext(Fi)
Ma = Application.Match(Fi.Offset(, 1).Value, Ws.Rows(1), 0)
If Not IsError(Ma) Then
C.Offset(, Ma - 1).Value = C.Offset(, Ma - 1).Value + 1
End If
Loop Until Ad = Fi.Address
Set Fi = Nothing
End If
Next C
End With
Application.ScreenUpdating = True
Set R = Nothing
End Sub
|
|