Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

44956 / 76732

←次へ　｜　前へ→


	【36783】Re:請求書シートを別のシートへコピーする

Kein - 06/4/13(木) 17:14 -


	引用なし

	パスワード

未テストですが・・

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　　　　　　　　

1 hits

▼

【36776】請求書シートを別のシートへコピーする かずみ 06/4/13(木) 15:40