【ノーコード】1分でExcelを自動化する無料ツール

コードの知識不要😊ChatGPTしようぜ⚾17

MENU

【ノーコードVBA】値が(不)一致で転記する(行全体)

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

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

(末尾に、VBAコード掲載) 

 

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

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

できました😊

 

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

パターンを見る

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

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

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

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

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

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

 

アプリの設定

アプリのトップページ

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

 ⇒【ツール】値が(不)一致で転記する(行全体)



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

 

表示される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

 

ChatGPTで修正

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

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

*1:キー