|
未テストですが・・
Sub Test_My集計()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Fv As Variant
Dim MyR As Range, FR As Range, C As Range
Dim LstR As Long
Set Sh1 = Worksheets("請求書")
Set Sh2 = Worksheets("売り上げ表")
If IsEmpty(Sh1.Range("A2").Value) Then GoTo LLine
For Each C In Sh1.Range("A2", Sh1.Range("A65536").End(xlUp))
Fv = Application _
.Match(C.Offset(, 2).Value, Sh2.Range("A:A"), 0)
If IsError(Fv) Then
If IsEmpty(Sh2.Cells(2, 1).Value) Then
Fv = 2
Else
Fv = Sh2.Cells(65536, 1).End(xlUp).Offset(500).Row
End If
Sh2.Cells(Fv, 1).Value = C.Offset(, 2).Value
Sh2.Cells(Fv, 2).Value = C.Value
Sh2.Cells(Fv, 3).Value = C.Offset(, 1).Value
Else
LstR = Sh2.Cells(Fv, 1).End(xlDown).Row - 1
Set MyR = _
Sh2.Range(Sh2.Cells(Fv, 1), Sh2.Cells(LstR, 1)).Offset(, 1)
Set FR = MyR.Find(C.Value, , xlValues, xlWhole)
If FR Is Nothing Then
If IsEmpty(Sh2.Cells(Fv, 2).Value) Then
Sh2.Cells(Fv, 2).Value = C.Value
Sh2.Cells(Fv, 3).Value = C.Offset(, 1).Value
Else
With Sh2.Cells(LstR, 2).End(xlUp)
.Offset(1).Value = C.Value
.Offset(1, 1).Value = C.Offset(, 1).Value
End With
End If
Else
FR.Offset(, 1).Value = _
FR.Offset(, 1).Value + C.Offset(, 1).Value
Set FR = Nothing
End If
Set MyR = Nothing
End If
Next
LLine:
Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub
|
|