マトリクス表→リスト表→様式に転記（横持データ→縦持データ）

産廃管理表から内訳書をチャットGPTで作ってもらいました。

オートフィルタした件名だけリスト表に転記させるところをチャットGPTが理解できずマクロの記録で可視セルのみ貼り付けをして何とか実現しました。

注１：電線くず、金属くずは買い取ってくれるので分けています。

注２：適宜シート名、セル位置など書き換えが必要です。

Sub 横縦()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim i As Long, j As Long, destRow As Long

    ' ソースシートとデスティネーションシートの設定
    Set wsSource = ThisWorkbook.Sheets("横")
    Set wsDestination = ThisWorkbook.Sheets("縦")

    ' デスティネーションシートの初期化
    wsDestination.Cells.Clear

    ' マトリクス表の見出しを取得
    Dim itemHeaders As Range
    Set itemHeaders = wsSource.Range("B1").Resize(1, wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column - 1)

    ' リスト表の見出しを設定
    wsDestination.Range("A1").Value = "件名"
    wsDestination.Range("B1").Value = "品目"
    wsDestination.Range("C1").Value = "データ"

    ' マトリクス表のデータを生成
    destRow = 1
    For i = 2 To wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
        If Not wsSource.Rows(i).Hidden Then
            For j = 2 To itemHeaders.Columns.Count + 1
                If Not wsSource.Cells(i, j).EntireRow.Hidden And Not wsSource.Cells(i, j).EntireColumn.Hidden Then
                    If wsSource.Cells(i, j).Value <> "" Then
                        destRow = destRow + 1
                        wsDestination.Cells(destRow, 1).Value = wsSource.Cells(i, 1).Value ' 件名
                        wsDestination.Cells(destRow, 2).Value = wsSource.Cells(1, j).Value ' 品目
                        wsDestination.Cells(destRow, 3).Value = wsSource.Cells(i, j).Value ' データ
                    End If
                End If
            Next j
        End If
    Next i

    Call 縦振り分け
    Call 内訳書へ1行飛ばし転記
    Call 縦後sheets削除
    
End Sub

Sub 縦振り分け()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    Dim i As Long

    ' 元のデータがあるシートを選択
    Set wsSource = Sheets("縦")

    ' 新しいデータを貼り付ける先のシートを作成
    Set wsTarget = Sheets.Add(After:=Sheets(Sheets.Count))
    wsTarget.Name = "縦後"

    ' 最終行を取得
    lastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row

    ' それ以外の行を新しいシートに移動
    For i = lastRow To 2 Step -1
        If InStr(1, wsSource.Cells(i, "B").Value, "金属くず") = 0 And InStr(1, wsSource.Cells(i, "B").Value, "電線くず") = 0 Then
            wsSource.Rows(i).Copy wsTarget.Rows(wsTarget.Cells(wsTarget.Rows.Count, "B").End(xlUp).Row + 1)
            wsSource.Rows(i).Delete Shift:=xlUp
        End If
    Next i
End Sub
Sub 内訳書へ1行飛ばし転記()
 Z = 0
For x = 2 To 50
        Worksheets("買取").Cells(x + 6 + Z, 2) = Worksheets("縦").Cells(x, 1).Value
        Worksheets("買取").Cells(x + 6 + Z, 3) = Worksheets("縦").Cells(x, 2).Value
        Worksheets("買取").Cells(x + 6 + Z, 6) = Worksheets("縦").Cells(x, 3).Value
        Worksheets("処分").Cells(x + 6 + Z, 2) = Worksheets("縦後").Cells(x, 1).Value
        Worksheets("処分").Cells(x + 6 + Z, 3) = Worksheets("縦後").Cells(x, 2).Value
        Worksheets("処分").Cells(x + 6 + Z, 6) = Worksheets("縦後").Cells(x, 3).Value
        Z = Z + 1
    Next
End Sub

Sub 縦後sheets削除()
    Application.DisplayAlerts = False ' メッセージを非表示
    Worksheets("縦後").Delete
End Sub