「NoCodeVBA」にようこそ！
「NoCodeVBA」はエクセルVBAマクロを作成する無料アプリです。
事例として「複数の値が一致したら、対応する値を転記値を転記する」VBAマクロを作成します。
なお、”検索値が一致したら、値を転記”するパターンは、
・値が一致したら（別のシートに）対応する値を転記 リンク
・値が一致したら（別のシートに）対応する複数の値を転記 リンク
・値が一致したら（別のシートに）対応する複数行を転記 リンク
があります。
事例 複数の値が一致したら、対応する値を転記する
左のデータを右の表の店舗などが一致する欄に、数量を転記します！
赤枠の部分に、数量を転記できました🤭
アプリの設定
⇒▼データ転記（上書更新・新規追加）
⇒【ツール】条件が一致したら転記
アプリに表示される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
セル範囲 = "a2" & ":" & Cells(最終行, Range("d2").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) & "|" & 対象行.Cells(1, 2) & "|" & 対象行.Cells(1, 3)
If 辞書.Exists(キー) Then
対象行.Select
MsgBox "選択した値に重複があるので終了します"
Exit Sub
Else
辞書(キー) = Array(対象行.Cells(1, 4))
End If
Next
'転記先 シートの選択
Sheets("Sheet1").Select
'表を配列に入れる
Dim 表配列() As Variant, 最終行2 As Long
最終行2 = Cells(Rows.Count, Range("f2").Column).Offset(0, 1 - 1).End(xlUp).Row
表配列 = Range("f2" & ":" & Cells(最終行2, Range("i2").Column).Address(False, False)).Value
'表配列に辞書のアイテムを入れる
Dim 行 As Long
For 行 = 1 To UBound(表配列)
If 辞書.Exists(表配列(行, 1) & "|" & 表配列(行, 2) & "|" & 表配列(行, 3)) Then
表配列(行, 4) = 辞書(表配列(行, 1) & "|" & 表配列(行, 2) & "|" & 表配列(行, 3))(0)
End If
Next 行
'表配列をシートに反映する
Sheets("Sheet1").Range("f2").Resize(UBound(表配列), UBound(表配列, 2)) = 表配列
'Application.ScreenUpdatingとApplication.DisplayAlertsをTrueに戻す
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
上記のコードで、値の転記ができました。😊
まとめ
手作業で数分かかる作業が、1秒で終わります。
ぜひ、アプリをご利用ください。