産廃管理表から内訳書をチャットGPTで作ってもらいました。
オートフィルタした件名だけリスト表に転記させるところをチャットGPTが理解できずマクロの記録で可視セルのみ貼り付けをして何とか実現しました。
注1:電線くず、金属くずは買い取ってくれるので分けています。
注2:適宜シート名、セル位置など書き換えが必要です。
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