商品毎に転記するVBAを、グループ毎に転記できるように改良したい。

Question

実現したいこと

“商品別売上日報EEMMDD”より、商品毎に集計シートへ転記する、既存のVBAをグループ毎に集計シートへ転記するように改良したい。

発生している問題・分からないこと

指定した複数行を、横並びではなく縦1列で貼り付ける方法

該当のソースコード

Sub CopyDataToSummary()
     Dim wbSummary As Workbook
     Dim wsTranscribe As Worksheet
     Dim wsBalance As Worksheet
     Dim folderPath As String
     Dim fileName As String
     'Dim dateToFind As String
     Dim dateToFind As Date
     Dim foundDate As Range

     ' 日報集計ブックを設定
     Set wbSummary = ThisWorkbook
     Set wsTranscribe = wbSummary.Sheets("転記")

     '日付を取得
     dateToFind = wsTranscribe.Range("C3").Value
     Debug.Print dateToFind

     ' 指定されたフォルダ内のファイルを検索
     folderPath = "H:\XXXXX\★AAAAAAA\BBBBBBBB\CC商品別売上日報　生データ"

     ' フォルダのパスを指定
     fileName = Dir(folderPath & "\商品別売上日報" & Format(dateToFind, "eemmdd")& ".xlsx")
     Debug.Print folderPath
     Debug.Print fileName

     ' ファイルが見つかった場合
     If fileName <> "" Then
         'ブックを開く
         Set wb = Workbooks.Open(folderPath & "\" & fileName)
         Set wsBalance = Worksheets("商品別売上日報（当日・前月)") wsBalance.Select
        
         ' 商品別売上日報（当日・前月)をコピーして貼付け
         CopyAndPasteData wsBalance.Range("F8:F28"),wbSummary.Sheets("商品A"), dateToFind
         CopyAndPasteData wsBalance.Range("G8:G28"),wbSummary.Sheets("商品B"), dateToFind
         CopyAndPasteData wsBalance.Range("J8:J28"),wbSummary.Sheets("商品C"), dateToFind
         CopyAndPasteData wsBalance.Range("K8:K28"),wbSummary.Sheets("商品D"), dateToFind
         CopyAndPasteData wsBalance.Range("L8:L28"),wbSummary.Sheets("商品E"), dateToFind
         CopyAndPasteData wsBalance.Range("N8:N28"),wbSummary.Sheets("商品F"), dateToFind
         CopyAndPasteData wsBalance.Range("O8:O28"),wbSummary.Sheets("商品G"), dateToFind
         CopyAndPasteData wsBalance.Range("P8:P28"),wbSummary.Sheets("商品H"), dateToFind
         CopyAndPasteData wsBalance.Range("Q8:Q28"),wbSummary.Sheets("商品I"), dateToFind
         CopyAndPasteData wsBalance.Range("R8:R28"),wbSummary.Sheets("商品J), dateToFind
         CopyAndPasteData wsBalance.Range("T8:T28"),wbSummary.Sheets("商品K"), dateToFind
         CopyAndPasteData wsBalance.Range("W8:W28"),wbSummary.Sheets("商品L"), dateToFind
         CopyAndPasteData wsBalance.Range("X8:X28"),wbSummary.Sheets("商品M"), dateToFind
         CopyAndPasteData wsBalance.Range("Y8:Y28"),wbSummary.Sheets("商品N"), dateToFind

         'ブックを閉じる
         ActiveWorkbook.Close
     Else
         MsgBox "指定された日付の残高日報が見つかりませんでした。"
     End If
End Sub

Sub CopyAndPasteData(rngSource As Range, wsTarget As Worksheet,
dateToFind As Date)
     Dim cell As Range
     Dim rngTarget As Range
     Dim wrng As Range

     Set rngTarget = Nothing
     For Each wrng In
wsTarget.Range("F1:Z1,F25:Z25,F49:Z49,F73:Z73,F97:Z97,F121:Z121")
         If wrng.Value = dateToFind Then
             Set rngTarget = wrng
             Exit For
         End If
     Next

     If Not rngTarget Is Nothing Then
             '貼り付ける
             rngSource.Copy
             wsTarget.Cells(rngTarget.Row + rngSource.Row -
rngSource.Cells(0, 1).Row, rngTarget.Column).PasteSpecial
Paste:=xlPasteValues
             Application.CutCopyMode = False

     End If

End Sub

試したこと・調べたこと

• teratailやGoogle等で検索した
• ソースコードを自分なりに変更した
• 知人に聞いた
• その他

上記の詳細・結果

wsBalance.Range("F8:F28")をwsBalance.Range("R8:R28,F8:F28")とすることで、指定した列をコピーすることは出来るが、貼り付けると2列で配置されるので、これを1列にして貼り付けたい。
また商品と商品の間には、スペース（前月比などがエクセル関数で入ってる）があるので、そのスペースに影響が出ないようにする必要もある。

補足

特になし

Comments

[sk.exe]

> グループ毎に集計シートへ転記する

> 指定した商品グループ毎に、シートへ転記

・[商品グループ]はどのようにして定義されているのか。

・それぞれの[商品]はどの[商品グループ]に属しているのか
　（何を以てそれを判別するのか）。

・全ての[商品グループ]のマスタや全ての[商品]のマスタに相当するリストは
　どこに、どのようにして定義されているのか。
　（そもそもそんなリストは存在しないのか）

以上の 3 点が不明なので、現時点では回答のしようがありません。

> 実際の日報は、商品は15種。

添付画像で例示された内容に照らし合わせるなら、
"商品グループ1"に含まれるのが"商品A"と"商品D"、
"商品グループ2"に含まれるのが"商品B"と"商品E"と"商品H"、
"商品グループ3"に含まれるのが"商品F"と"商品C"
というところまでは読み取れますが、残りの 8 商品がそれぞれどの[商品グループ]に含まれるのかが判りません。

また"商品グループ3"に属する商品については、日報ファイル上での並び順と集計シート上の並び順が一致していないようですが、[商品グループ]（集計シート）ごとに定められた任意の並び順に入れ替える形でデータを出力する必要があるのでしょうか。

[ATSUHAYAshi]

既存のコードに商品A～Nとあるのは、既存のコードではグループを考える必要がなかった為、
実際は、同じ商品の個人向け、法人向けでグループがあり、個人向け商品の中で、商品Cグループ、Dグループがあります。

商品Aは、法人向けのみなのでグループなし。
商品Bは、法人向け、個人向けでの１つのグループ
商品Cは、個人向け（3商品）で１つのグループ
商品Dは、個人向け（2商品）で１つのグループになっています。

[logres_Fan]

日報シートのセルを参照するように集計シートを作れば終わる仕事じゃないの？

[sk.exe]

追記された説明を拝見した限り、「既存のマクロを改良する」より「既存のマクロとは別に新しいマクロを作成する」方がよいと思います。

例示されたように「複数ある貼り付け先シートの構造が統一されていない」
「コピー元/貼り付け先となるセル領域の捉え方が商品によって大きく異なる」
「一部の商品については例外的な（Y28セルの）コピー/貼り付け処理が発生する」
ということなら、少なくとも CopyAndPasteData のような共通化ルーチンに置き換えるのは無理筋です。
それぞれの商品（貼り付け先シート）に合わせた制御フローを個別に検討されることをお奨めします。

ワークシート[範囲]の C3 セルの値に応じて動的に変更されるべきなのは「コピー元となるブックのパス」と「貼り付け先となる範囲の列位置」のみであり、それ以外の要素についてはほぼ決め打ちでよいはずです。

Answer 1

既存のマクロとは別に新しいマクロを作成する

とりあえず、追記された説明の通りの処理を実行される場合のサンプルを例示します。

Sub CopyDataToSummary2()

    Dim wbSummary As Workbook
    Dim wsTranscribe As Worksheet
     
    Set wbSummary = ThisWorkbook
    Set wsTranscribe = wbSummary.Worksheets("転記")
    
    'C3セルの値が日時データではない場合
    If IsDate(wsTranscribe.Range("C3").Value) = False Then
        wbSummary.Activate
        wsTranscribe.Select
        wsTranscribe.Range("C3").Select
        MsgBox "集計対象となる日付を入力してください。", _
                vbExclamation, _
                "入力エラー"
        Set wsTranscribe = Nothing
        Set wbSummary = Nothing
        Exit Sub
    End If
    
    Dim dateToFind As Date
    Dim folderPath As String
    Dim fileName As String
    
    '参照対象となる日報の日付を取得
    dateToFind = wsTranscribe.Range("C3").Value
    Debug.Print dateToFind
    
    '日報ブックが保存されているフォルダのパスを指定
    folderPath = "H:\XXXXX\★AAAAAAA\BBBBBBBB\CC商品別売上日報　生データ"
    Debug.Print folderPath
    
    'フォルダが見つからなかった場合
    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "パス""" & fileName & """に該当するフォルダが見つかりません。", _
                vbExclamation, _
                "フォルダ参照エラー"
        Set wsTranscribe = Nothing
        Set wbSummary = Nothing
        Exit Sub
    End If
    
    '対象日付に該当する日報ブックのファイルパスを生成
    fileName = folderPath & "\商品別売上日報" & Format(dateToFind, "eemmdd") & ".xlsx"
    Debug.Print fileName

    'ファイルが見つからなかった場合
    If Dir(fileName) = "" Then
        MsgBox "パス""" & fileName & """に該当するブックが見つかりません。", _
                vbExclamation, _
                "ファイル参照エラー"
        Set wsTranscribe = Nothing
        Set wbSummary = Nothing
        Exit Sub
    End If
    
    Dim wbDailyReport As Workbook
    Dim wsBalance As Worksheet
    
    '日報ブックを開いて参照
    Set wbDailyReport = Workbooks.Open(fileName)
    '日報シートを参照
    Set wsBalance = wbDailyReport.Worksheets("商品別売上日報（当日・前月)")
    
    Dim rngDestinationHeader As Range
    Dim rngFoundCell As Range
    Dim headerFirstColumn As String
    Dim headerColumnSize As Long
    Dim balanceFirstDataRow As Long
    Dim dataRowSize As Long
    
    '集計シート上の日付ヘッダーの最初の列位置
    headerFirstColumn = "F"
    '集計シート上の日付ヘッダーの列数
    headerColumnSize = 21
    '日報シートの先頭のデータ行の行番号
    balanceFirstDataRow = 8
    'データ行の行数
    dataRowSize = 21
    
    'ワークシート[商品A]を集計シートとして以下の処理を実行
    With wbSummary.Worksheets("商品A")
        '3行目を基点としてヘッダー範囲を参照
        Set rngDestinationHeader = .Cells(3, headerFirstColumn).Resize(1, headerColumnSize)
        'ヘッダー範囲から対象日付に該当するセルを検索
        Set rngFoundCell = FindDateFromHeader(rngDestinationHeader, dateToFind)
        'ヒットした場合
        If Not rngFoundCell Is Nothing Then
            '日報シートのU列のデータ行の値を集計シートの該当列のデータ行に複写
            CopyColumnValues wsBalance.Cells(balanceFirstDataRow, "U"), rngFoundCell.Offset(1, 0), dataRowSize
        End If
        Set rngFoundCell = Nothing
        Set rngDestinationHeader = Nothing
    
    End With
 
    'ワークシート[商品B]を集計シートとして以下の処理を実行
    With wbSummary.Worksheets("商品B")
        
        '3行目を基点としてヘッダー範囲を参照
        Set rngDestinationHeader = .Cells(3, headerFirstColumn).Resize(1, headerColumnSize)
        'ヘッダー範囲から対象日付に該当するセルを検索
        Set rngFoundCell = FindDateFromHeader(rngDestinationHeader, dateToFind)
        'ヒットした場合
        If Not rngFoundCell Is Nothing Then
            '日報シートのM列のデータ行の値を集計シートの該当列のデータ行に複写
            CopyColumnValues wsBalance.Cells(balanceFirstDataRow, "M"), rngFoundCell.Offset(1, 0), dataRowSize
        End If
        Set rngFoundCell = Nothing
        Set rngDestinationHeader = Nothing
    
        '27行目を基点としてヘッダー範囲を参照
        Set rngDestinationHeader = .Cells(27, headerFirstColumn).Resize(1, headerColumnSize)
        'ヘッダー範囲から対象日付に該当するセルを検索
        Set rngFoundCell = FindDateFromHeader(rngDestinationHeader, dateToFind)
        'ヒットした場合
        If Not rngFoundCell Is Nothing Then
            '日報シートのV列のデータ行の値を集計シートの該当列のデータ行に複写
            CopyColumnValues wsBalance.Cells(balanceFirstDataRow, "V"), rngFoundCell.Offset(1, 0), dataRowSize
        End If
        Set rngFoundCell = Nothing
        Set rngDestinationHeader = Nothing
    
    End With
 
    'ワークシート[商品C_個人向け]を集計シートとして以下の処理を実行
    With wbSummary.Worksheets("商品C_個人向け")
        
        '3行目を基点としてヘッダー範囲を参照
        Set rngDestinationHeader = .Cells(3, headerFirstColumn).Resize(1, headerColumnSize)
        'ヘッダー範囲から対象日付に該当するセルを検索
        Set rngFoundCell = FindDateFromHeader(rngDestinationHeader, dateToFind)
        'ヒットした場合
        If Not rngFoundCell Is Nothing Then
            '日報シートのO列のデータ行の値を集計シートの該当列のデータ行に複写
            CopyColumnValues wsBalance.Cells(balanceFirstDataRow, "O"), rngFoundCell.Offset(1, 0), dataRowSize
        End If
        Set rngFoundCell = Nothing
        Set rngDestinationHeader = Nothing
    
        '27行目を基点としてヘッダー範囲を参照
        Set rngDestinationHeader = .Cells(27, headerFirstColumn).Resize(1, headerColumnSize)
        Set rngFoundCell = FindDateFromHeader(rngDestinationHeader, dateToFind)
        'ヒットした場合
        If Not rngFoundCell Is Nothing Then
            '日報シートのP列のデータ行の値を集計シートの該当列のデータ行に複写
            CopyColumnValues wsBalance.Cells(balanceFirstDataRow, "P"), rngFoundCell.Offset(1, 0), dataRowSize
        End If
        Set rngFoundCell = Nothing
        Set rngDestinationHeader = Nothing
    
        '51行目を基点としてヘッダー範囲を参照
        Set rngDestinationHeader = .Cells(51, headerFirstColumn).Resize(1, headerColumnSize)
        'ヘッダー範囲から対象日付に該当するセルを検索
        Set rngFoundCell = FindDateFromHeader(rngDestinationHeader, dateToFind)
        'ヒットした場合
        If Not rngFoundCell Is Nothing Then
            '日報シートのQ列のデータ行の値を集計シートの該当列のデータ行に複写
            CopyColumnValues wsBalance.Cells(balanceFirstDataRow, "Q"), rngFoundCell.Offset(1, 0), dataRowSize
        End If
        Set rngFoundCell = Nothing
        Set rngDestinationHeader = Nothing
        
    End With
 
    'ワークシート[商品C_法人向け]を集計シートとして以下の処理を実行
    With wbSummary.Worksheets("商品C_法人向け")
        
        '3行目を基点としてヘッダー範囲を参照
        Set rngDestinationHeader = .Cells(3, headerFirstColumn).Resize(1, headerColumnSize)
        'ヘッダー範囲から対象日付に該当するセルを検索
        Set rngFoundCell = FindDateFromHeader(rngDestinationHeader, dateToFind)
        'ヒットした場合
        If Not rngFoundCell Is Nothing Then
            '日報シートのW列のデータ行の値を集計シートの該当列のデータ行に複写
            CopyColumnValues wsBalance.Cells(balanceFirstDataRow, "W"), rngFoundCell.Offset(1, 0), dataRowSize
            
            '例外的な代入処理
            '日報シートのY28セルの値を集計シートの該当列の74行目のセルに代入
            .Cells(74, rngFoundCell.Column).Value = wsBalance.Range("Y28").Value
        
        End If
        Set rngFoundCell = Nothing
        Set rngDestinationHeader = Nothing
    
    End With
 
    'ワークシート[商品D_個人向け]を集計シートとして以下の処理を実行
    With wbSummary.Worksheets("商品D_個人向け")
        
        '3行目を基点としてヘッダー範囲を参照
        Set rngDestinationHeader = .Cells(3, headerFirstColumn).Resize(1, headerColumnSize)
        'ヘッダー範囲から対象日付に該当するセルを検索
        Set rngFoundCell = FindDateFromHeader(rngDestinationHeader, dateToFind)
        'ヒットした場合
        If Not rngFoundCell Is Nothing Then
            '日報シートのR列のデータ行の値を集計シートの該当列のデータ行に複写
            CopyColumnValues wsBalance.Cells(balanceFirstDataRow, "R"), rngFoundCell.Offset(1, 0), dataRowSize
        End If
        Set rngFoundCell = Nothing
        Set rngDestinationHeader = Nothing
    
        '27行目を基点としてヘッダー範囲を参照
        Set rngDestinationHeader = .Cells(27, headerFirstColumn).Resize(1, headerColumnSize)
        'ヘッダー範囲から対象日付に該当するセルを検索
        Set rngFoundCell = FindDateFromHeader(rngDestinationHeader, dateToFind)
        'ヒットした場合
        If Not rngFoundCell Is Nothing Then
            '日報シートのS列のデータ行の値を集計シートの該当列のデータ行に複写
            CopyColumnValues wsBalance.Cells(balanceFirstDataRow, "S"), rngFoundCell.Offset(1, 0), dataRowSize
        End If
        Set rngFoundCell = Nothing
        Set rngDestinationHeader = Nothing
    
    End With
 
    'ワークシート[商品D_法人向け]を集計シートとして以下の処理を実行
    With wbSummary.Worksheets("商品D_法人向け")
        
        '3行目を基点としてヘッダー範囲を参照
        Set rngDestinationHeader = .Cells(3, headerFirstColumn).Resize(1, headerColumnSize)
        'ヘッダー範囲から対象日付に該当するセルを検索
        Set rngFoundCell = FindDateFromHeader(rngDestinationHeader, dateToFind)
        'ヒットした場合
        If Not rngFoundCell Is Nothing Then
            '日報シートのX列のデータ行の値を集計シートの該当列のデータ行に複写
            CopyColumnValues wsBalance.Cells(balanceFirstDataRow, "X"), rngFoundCell.Offset(1, 0), dataRowSize
        End If
        Set rngFoundCell = Nothing
        Set rngDestinationHeader = Nothing
    
    End With
    
    '日報ブックを閉じる
    Set wsBalance = Nothing
    wbDailyReport.Close False
    Set wbDailyReport = Nothing

    With wbSummary.Worksheets("商品A")
        .Select
        .Cells(3, headerFirstColumn).Select
    End With

    Set wsTranscribe = Nothing
    Set wbSummary = Nothing
    
    MsgBox "複写処理が完了しました。", _
            vbInformation, _
            "実行完了"

End Sub

'該当日付列の検索処理
Private Function FindDateFromHeader(Header As Range, FindDate As Date) As Range

    If Header Is Nothing Then
        Exit Function
    End If
    
    Dim rngLoop As Range
    
    For Each rngLoop In Header.Cells
        If rngLoop.Value = FindDate Then
            Set FindDateFromHeader = rngLoop
            Exit Function
        End If
    Next

End Function

'データ複写用処理
Private Sub CopyColumnValues(SourceTopCell As Range, DestinationTopCell As Range, RowSize As Long)

    If SourceTopCell Is Nothing Then
        Exit Sub
    End If

    If DestinationTopCell Is Nothing Then
        Exit Sub
    End If

    Dim rngSource As Range
    Dim rngDestination As Range
    
    Set rngSource = SourceTopCell.Resize(RowSize, 1)
    Set rngDestination = DestinationTopCell.Resize(RowSize, 1)

     rngDestination.Value = rngSource.Value
    
    Set rngSource = Nothing
    Set rngDestination = Nothing

End Sub