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 質問
【36777】Re:請求書シートを別のシートへコピーする Statis 06/4/13(木) 16:06 発言
【36780】Re:請求書シートを別のシートへコピーする かずみ 06/4/13(木) 16:19 質問
【36782】Re:請求書シートを別のシートへコピーする Statis 06/4/13(木) 16:40 回答
【36783】Re:請求書シートを別のシートへコピーする Kein 06/4/13(木) 17:14 回答

44956 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free