【ﾉｰｺｰﾄﾞVBA】フィルターした結果を、一致する値に転記する

エクセルVBAマクロを自動作成する無料アプリです。

例として「フィルターした結果を、一致する値に転記する」VBAマクロを作成します。

事例　フィルターした結果を、一致する値に転記する

ポイント
・アプリで「一致する値に転記する」VBAコードを作り、そのコードを「フィルターした結果を、一致する値に転記する」コードにChatGPTでカスタマイズします。

アプリへのリンク

アプリへのリンク
　⇒値が一致したら転記する

アプリの画面

作成されたコード

アプリで作成したコードを、VBE画面に貼り付けて実行します。

まず、すべての日付が入ったデータが作成されました。

アプリで作成したコードの概要をChatGPTで確認します。

上記コードは、「Sheet1 のデータを読み込み、tableArray に格納」することがわかりました。　

カスタマイズは、「tableArray に格納する前に、A列をG2セルの値でフィルターし、その結果をtableArray に格納」することにします。

ChatGPTで、コードをカスタマイズします。

上記のコードをVBEに貼り付けて、実行します。

日付でフィルターされた値だけが、商品名の横に転記されました。

できました😊

VBAコードを見る

Sub デモ() '値が一致したら転記する
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim lastRow As Long, tableArray() As Variant
    Dim filterValue As String
    filterValue = Sheets("Sheet1").Range("G2").Value ' G2セルの値を取得
    
    Sheets("Sheet1").Select
    lastRow = Cells(Rows.Count, Range("A2").Column).End(xlUp).Row
    
    ' A列をフィルターして、フィルター結果をtableArrayに格納
    Dim filteredRange As Range
    Set filteredRange = Range("A2:E" & lastRow).SpecialCells(xlCellTypeVisible)
    tableArray = filteredRange.Value
    
    Dim myKey As Variant, targetRow As Long
    For targetRow = 1 To UBound(tableArray, 1)
        If tableArray(targetRow, 1) = filterValue Then ' フィルター条件をチェック
            myKey = tableArray(targetRow, 2)
            If dict.Exists(myKey) Then
                dict(myKey) = Array(dict(myKey)(0) & vbCrLf & tableArray(targetRow, 1), dict(myKey)(1) & vbCrLf & tableArray(targetRow, 3), dict(myKey)(2) & vbCrLf & tableArray(targetRow, 4), dict(myKey)(3) & vbCrLf & tableArray(targetRow, 5))
            Else
                dict(myKey) = Array(tableArray(targetRow, 1), tableArray(targetRow, 3), tableArray(targetRow, 4), tableArray(targetRow, 5))
            End If
        End If
    Next
    Erase tableArray

    Sheets("Sheet1").Select

    Dim targetArray() As Variant, lastRow2 As Long
    lastRow2 = Cells(Rows.Count, Range("G7").Column).Offset(0, 1 - 1).End(xlUp).Row
    targetArray = Range("G7" & ":" & Cells(lastRow2, Range("K7").Column).Address(False, False)).Value

    Dim myRow As Long
    For myRow = 1 To UBound(targetArray, 1)
        myKey = targetArray(myRow, 1)
        If dict.Exists(myKey) Then
            targetArray(myRow, 2) = dict(myKey)(0)
            targetArray(myRow, 3) = dict(myKey)(1)
            targetArray(myRow, 4) = dict(myKey)(2)
            targetArray(myRow, 5) = dict(myKey)(3)
        End If
    Next myRow

    Sheets("Sheet1").Range("G7").Resize(UBound(targetArray), UBound(targetArray, 2)).Value = targetArray
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub