-ChatGPT4-に質問　あるデータとあるデータをまとめてピポットテーブルを使った消込を行う

2023.04.18

-ChatGPT4-

-ChatGPT4-に質問

VBAでダイアログボックスで選択したファイルの編集用という文字列が部分一致のシートをコピーして新規ファイルに貼り付けてください。そしてそのシートをコピーして消込用というシートを作成します。もう一回、ダイアログボックスで選択した他のファイルの編集用という文字列が部分一致のシートをコピーしてさきほどの新規ファイルに貼り付けます。

消込用シートを作成した時にA列の１行目を消込という文字列に変えて、２行目からデータがあるまでシート名を代入してください。再度ダイアログボックスを選択したときに最終行の偉１行下からA列にシート名を入れてください。

従来のピポットテーブルを作成してください。行フィールドに会社名を追加、列フィールドにフラグを追加、値フィールドに金額を追加し、値のみを別のシートに貼り付けてください。

ChatGPT4の回答

Option Explicit

Sub CopySheetsAndModify()
    Dim sourceWorkbook As Workbook
    Dim sourceWorksheet As Worksheet
    Dim newWorkbook As Workbook
    Dim targetWorksheet As Worksheet
    Dim secondSourceWorksheet As Worksheet
    Dim lastRow As Long, lastColumn As Long

    ' 新しいワークブックを作成
    Set newWorkbook = Workbooks.Add

    ' ダイアログボックスで選択したファイルの編集用シートをコピー
    Set sourceWorksheet = SelectWorksheet("編集用")
    If Not sourceWorksheet Is Nothing Then
        sourceWorksheet.Copy Before:=newWorkbook.Sheets(1)
    Else
        MsgBox "編集用シートが見つかりませんでした。", vbCritical, "エラー"
        Exit Sub
    End If

    ' 消込用シートを作成
    Set targetWorksheet = newWorkbook.Worksheets.Add(After:=newWorkbook.Worksheets(1))
    targetWorksheet.Name = "消込用"
    

    ' 最初のダイアログボックスで取り込んだシートを消込用シートに貼り付け
    sourceWorksheet.Cells.Copy targetWorksheet.Cells
    
    'A列の最終行を取得
    lastRow = targetWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
    ' A1セルに"消込"という文字列を挿入
    targetWorksheet.Cells(1, "A").Value = "消込"

   ' A2セルからデータがあるまでシート名を代入
    lastRow = sourceWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow
        targetWorksheet.Cells(i, "A").Value = sourceWorksheet.Name
    Next i
    ' 再度ダイアログボックスで選択した別のファイルの編集用シートをコピー
    Set secondSourceWorksheet = SelectWorksheet("編集用")
    If Not secondSourceWorksheet Is Nothing Then
        secondSourceWorksheet.Copy Before:=newWorkbook.Sheets(1)
    Else
        MsgBox "編集用シートが見つかりませんでした。", vbCritical, "エラー"
        Exit Sub
    End If
    
    If Not secondSourceWorksheet Is Nothing Then
        
        ' 消込用シートのA列の最終行の1行下にシート名を挿入
        lastRow2 = secondSourceWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
        For i = 1 To lastRow2
            targetWorksheet.Cells(lastRow + i, "A").Value = secondSourceWorksheet.Name
        Next i
        ' 消込用シートのD列の最終行の一行下に、最終列から数えて2列目にある行のデータすべてを代入
        lastRow = targetWorksheet.Cells(Rows.Count, "D").End(xlUp).Row
        lastColumn = secondSourceWorksheet.Cells(1, Columns.Count).End(xlToLeft).Column
        secondSourceWorksheet.Range(secondSourceWorksheet.Cells(1, lastColumn - 1), secondSourceWorksheet.Cells(secondSourceWorksheet.Rows.Count, lastColumn - 1).End(xlUp)).Copy _
            targetWorksheet.Cells(lastRow + 1, "D")

        ' 消込用シートの最終列の後ろから数えて5列目の最終行の一行下にV列にある行のデータすべてを代入
        secondSourceWorksheet.Range("V1", secondSourceWorksheet.Cells(secondSourceWorksheet.Rows.Count, "V").End(xlUp)).Copy _
            targetWorksheet.Cells(lastRow + 1, "BT")
    Else
        MsgBox "編集用シートが見つかりませんでした。", vbCritical, "エラー"
        Exit Sub
    End If
    
   ' ピボットテーブルを作成
    CreatePivotTable targetWorksheet

    ' 確認メッセージ
    MsgBox "処理が完了しました。", vbInformation, "完了"
End Sub

Sub CreatePivotTable(sourceWorksheet As Worksheet)
    Dim pivotCache As PivotCache
    Dim pivotTable As PivotTable
    Dim dataRange As Range
    Dim targetWorksheet As Worksheet
    Dim pasteValuesWorksheet As Worksheet
    Dim lastRow As Long
    Dim lastColumn As Long

    ' 最終行と最終列を取得
    lastRow = sourceWorksheet.Cells(sourceWorksheet.Rows.Count, "A").End(xlUp).Row
    lastColumn = sourceWorksheet.Cells(1, sourceWorksheet.Columns.Count).End(xlToLeft).Column

    ' データ範囲を設定
    Set dataRange = sourceWorksheet.Cells(1, 1).Resize(lastRow, lastColumn)

    ' ピボットキャッシュを作成
    Set pivotCache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=dataRange)

    ' 新しいワークシートを作成
    Set targetWorksheet = Worksheets.Add

    ' ワークシートの名前を "Pivot" に設定
    targetWorksheet.Name = "Pivot"

    ' ピボットテーブルを作成
Set pivotTable = pivotCache.CreatePivotTable(TableDestination:=targetWorksheet.Cells(1, 1), TableName:="PivotTable1")


    ' フィールドを設定
    With pivotTable
        .PivotFields("INVOICE_NUMBER").Orientation = xlRowField
        .PivotFields("貸方補助科目").Orientation = xlRowField
        .PivotFields("消込").Orientation = xlColumnField
        .AddDataField .PivotFields("金額2"), "Sum of 金額2", xlSum
    End With

' 貸方補助科目を2列目に表示
    pivotTable.PivotFields("貸方補助科目").Position = 2

' INVOICE_NUMBER と 貸方補助科目 の小計を無効にする
With pivotTable
    .PivotFields("INVOICE_NUMBER").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
    .PivotFields("貸方補助科目").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With

' 従来のピポットテーブル設定を適用
pivotTable.RowAxisLayout xlTabularRow
pivotTable.MergeLabels = True



    ' コピーして値だけを貼り付ける新しいワークシートを作成
    Set pasteValuesWorksheet = Worksheets.Add

    ' ワークシートの名前を "Pivot値貼り付け" に設定
    pasteValuesWorksheet.Name = "Pivot値貼り付け"

    ' ピボットテーブルの範囲をコピー
    pivotTable.TableRange1.Copy

    ' 新しいワークシートに値だけを貼り付け
    pasteValuesWorksheet.Cells(1, 1).PasteSpecial Paste:=xlPasteValues

    ' クリップボードをクリア
    Application.CutCopyMode = False

End Sub



Function SelectWorksheet(sheetNameContains As String) As Worksheet
    Dim selectedWorkbook As Workbook
    Dim selectedWorksheet As Worksheet

    ' ファイル選択ダイアログボックスを表示
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "ファイルを選択してください"
        If .Show = -1 Then
            ' 選択したファイルを開く
            Set selectedWorkbook = Workbooks.Open(.SelectedItems(1))
        Else
            Exit Function
        End If
    End With

    ' シート名に指定された文字列を含むシートを探す
    For Each selectedWorksheet In selectedWorkbook.Worksheets
        If InStr(1, selectedWorksheet.Name, sheetNameContains) > 0 Then
            Set SelectWorksheet = selectedWorksheet
            Exit Function
        End If
    Next selectedWorksheet
End Function
タイトルとURLをコピーしました