2023-12-18

【ﾉｰｺｰﾄﾞ】値が（不）一致で行全体を転記する

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

例として「値が一致で行全体を転記する」VBAマクロを作成します。
なお、「値が不一致で行を転記」することもできます。

事例　新にある品名と産地が、マスターに一致したら一致に転記、不一致は不一致に転記する
- アプリの設定
- 表示されるVBAコード
ChatGPTで修正
アプリはこちらから↓↓↓↓

事例　新にある品名と産地が、マスターに一致したら一致に転記、不一致は不一致に転記する

※　一致か不一致いずれかのみ表示することも可能です。

できました😊

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

パターンを見る

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

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

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

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

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

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

アプリの設定

アプリへのリンク
　⇒値が（不）一致で行全体を転記する

ポイント
■　マスターの「みかん」が重複していますが、品質の違いで複数登録があり得るので、上図の赤枠のように重複チェックは解除しています。

表示されるVBAコード

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

VBAコードを見る

'Sub デモ() '値が（不）一致で転記する（行全体）

Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止

'辞書オブジェクトの作成
Dim 辞書 As Object
Set 辞書 = CreateObject("Scripting.Dictionary")
'マスタの設定
Sheets("Sheet1").Select
Dim 最終行 As Long, マスタ表 As Range
最終行 = Cells(Rows.Count, Range("e3").Column).End(xlUp).Row
Set マスタ表 = Range("e3" & ":" & Cells(最終行, Range("g3").Column).Address(False, False))
'マスタ辞書の作成
Dim キー As Variant, 行 As Range
For Each 行 In マスタ表.Rows
キー = 行.Cells(1, 1) & "|" & 行.Cells(1, 2)
If 辞書.Exists(キー) Then
Else
辞書(キー) = Array(行.Cells(1, 1), 行.Cells(1, 2), 行.Cells(1, 3))
End If
Next
Set マスタ表 = Nothing
'新データの選択
Sheets("Sheet1").Select
'対象を配列に入れる
Dim 対象配列() As Variant, 対象最終行 As Long
対象最終行 = Cells(Rows.Count, Range("a3").Column).End(xlUp).Row
対象配列 = Range("a3" & ":" & Cells(対象最終行, Range("c3").Column).Address(False, False)).Value
'配列を初期化
Dim 一致配列() As Variant, 不一致配列() As Variant
ReDim 一致配列(1 To UBound(対象配列, 1), 1 To UBound(対象配列, 2))
ReDim 不一致配列(1 To UBound(対象配列, 1), 1 To UBound(対象配列, 2))
'辞書で対象配列を振り分け
Dim 対象行 As Long, 一致行 As Long, 不一致行 As Long
一致行 = 1
不一致行 = 1
For 対象行 = 1 To UBound(対象配列)
キー = 対象配列(対象行, 1) & "|" & 対象配列(対象行, 2)
If 辞書.Exists*1 Then
一致配列(一致行, 1) = 辞書(キー)(0)
一致配列(一致行, 2) = 辞書(キー)(1)
一致配列(一致行, 3) = 辞書(キー)(2)
一致行 = 一致行 + 1
Else
不一致配列(不一致行, 1) = 対象配列(対象行, 1)
不一致配列(不一致行, 2) = 対象配列(対象行, 2)
不一致配列(不一致行, 3) = 対象配列(対象行, 3)
不一致行 = 不一致行 + 1
End If
Next 対象行
'対象配列をシートに反映する
Sheets("Sheet1").Range("i3").Resize(UBound(対象配列), UBound(対象配列, 2)).Value = 一致配列
Sheets("Sheet1").Range("m3").Resize(UBound(対象配列), UBound(対象配列, 2)).Value = 不一致配列
'Application.ScreenUpdatingとApplication.DisplayAlertsをTrueに戻す
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub