VBAマクロを自動作成する無料アプリ

VBAコードの知識不要😊ChatGPTで機能を追加

MENU

【ノーコード】値が一致したら(別のシートに)対応する複数の値を転記(コピー)する(連想配列)

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

例として「値が一致したら(別のシートに)対応する複数の値を転記(コピー)」するVBAマクロを作成します。

 事例1 「値が一致したら対応する複数の値を転記

 事例2 「日付が一致する欄に、複数の値を転記

事例1  会員番号が一致する、氏名、ふりがな、都道府県を転記する 

 

※ 別シートへの転記も可能です。

転記できました😊

 

なお、値が一致したら転記のパターンは下記があります😊

パターンを見る

値が一致したら、1行すべてを転記する|連想配列|連想配列

値が一致しなければ、1行すべてを転記する|連想配列

値が一致したら、値の横にデータを転記する|連想配列

値が一致したら、値の横で既存データは上書き、新規データは追加|連想配列

値が部分一致したら、データを転記する|フィルター

複数項目を、それぞれ異なる条件で転記する|フィルターオプション

 

アプリの設定

アプリの設定です。

アプリのトップページ 

 ⇒▼2つの表(転記・上書き・新規追加・比較))

 ⇒【ツール】値が一致したら転記する

 

表示されるVBAコード 

アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。

 

VBAコードを見る

Sub デモ() 'データの項目が一致したら、値を転記する 
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False  ' 警告表示を停止
Dim セル範囲 As String, セル As Range, 右下セル As String
Sheets("Sheet1").Select
'表の最終行を決定
Dim 最終行 As Long
最終行 = Cells(Rows.Count, Range("A1").Column).End(xlUp).Row
セル範囲 = "a1" & ":" & Cells(最終行, Range("d1").Column).Address(False, False) 
'辞書オブジェクトの作成
    Dim 辞書 As Object
    Set 辞書 = CreateObject("Scripting.Dictionary")
'対象セルの設定
    Dim 対象セル As Range
    Set 対象セル = Range(セル範囲)
'辞書の作成
    Dim キー As Variant, 対象行 As Range
    For Each 対象行 In 対象セル.Rows
        キー = 対象行.Cells(1, 1)
        If 辞書.Exists(キー) Then
            対象行.Select
            MsgBox "選択した値に重複があるので終了します"
            Exit Sub
        Else
            辞書(キー) = Array(対象行.Cells(1, 2), 対象行.Cells(1, 3), 対象行.Cells(1, 4))
        End If
    Next
'転記先 シートの選択
    Sheets("Sheet1").Select
'表を配列に入れる
    Dim 表配列() As Variant, 最終行2 As Long
    最終行2 = Cells(Rows.Count, Range("f1").Column).Offset(0, 1 - 1).End(xlUp).Row
    表配列 = Range("f1" & ":" & Cells(最終行2, Range("i1").Column).Address(False, False)).Value
'表配列に辞書のアイテムを入れる
Dim 行 As Long
  For 行 = 1 To UBound(表配列)
    If 辞書.Exists(表配列(行, 1)) Then
    表配列(行, 2) = 辞書(表配列(行, 1))(0)
    表配列(行, 3) = 辞書(表配列(行, 1))(1)
    表配列(行, 4) = 辞書(表配列(行, 1))(2)  
  End If
Next 行
'表配列をシートに反映する
    Sheets("Sheet1").Range("f1").Resize(UBound(表配列), UBound(表配列, 2)) = 表配列
'Application.ScreenUpdatingとApplication.DisplayAlertsをTrueに戻す
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

事例2  日付が一致する欄に、複数の値を転記する 

※ 別シートに転記も可能です。

転記できました😊

アプリの設定

アプリの設定です。

アプリのトップページ 

 ⇒2つの表(転記・上書き・新規追加・比較)

 ⇒【ツール】値が一致したら転記する

表示されるVBAコード 

アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。

 

VBAコードを見る

Sub デモ() 'データの項目が一致したら、値を転記する 
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False  ' 警告表示を停止
Dim セル範囲 As String, セル As Range, 右下セル As String
Sheets("Sheet1").Select
セル範囲 = "a3:e3" 
'辞書オブジェクトの作成
    Dim 辞書 As Object
    Set 辞書 = CreateObject("Scripting.Dictionary")
'対象セルの設定
    Dim 対象セル As Range
    Set 対象セル = Range(セル範囲)
'辞書の作成
    Dim キー As Variant, 対象行 As Range
    For Each 対象行 In 対象セル.Rows
        キー = 対象行.Cells(1, 1)
        If 辞書.Exists(キー) Then
            対象行.Select
            MsgBox "選択した値に重複があるので終了します"
            Exit Sub
        Else
            辞書(キー) = Array(対象行.Cells(1, 3), 対象行.Cells(1, 4), 対象行.Cells(1, 5))
        End If
    Next
'転記先 シートの選択
    Sheets("Sheet1").Select
'表を配列に入れる
    Dim 表配列() As Variant, 最終行2 As Long
    最終行2 = Cells(Rows.Count, Range("g2").Column).Offset(0, 1 - 1).End(xlUp).Row
    表配列 = Range("g2" & ":" & Cells(最終行2, Range("j2").Column).Address(False, False)).Value
'表配列に辞書のアイテムを入れる
Dim 行 As Long
  For 行 = 1 To UBound(表配列)
     If 辞書.Exists(表配列(行, 1)) Then
      表配列(行, 2) = 辞書(表配列(行, 1))(0)
      表配列(行, 3) = 辞書(表配列(行, 1))(1)
      表配列(行, 4) = 辞書(表配列(行, 1))(2)  
    End If
 Next 行
'表配列をシートに反映する
    Sheets("Sheet1").Range("g2").Resize(UBound(表配列), UBound(表配列, 2)) = 表配列
'Application.ScreenUpdatingとApplication.DisplayAlertsをTrueに戻す
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

ChatGPTで修正

あなたが自動化したい内容と事例が少し異なる場合は、無料で使えるマイクロソフトの「BingAIチャット」でコードを修正します。とても簡単です!

アプリはこちらから↓↓↓↓