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

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

MENU

【ノーコード】通し番号がある表を比較し、違うセルに色を付ける

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

例として「通し番号がある表を比較し、違うセルに色を付ける」VBAマクロを作成します。表の形式が異なっても、対応可能です。

事例 相違点に色を付ける

できました😃

 

なお表の比較は、4つパターンがあります😊

パターンを見る

表を比較し、違うに色を付ける|Dictionary

通し番号がある表を比較し、違うセルに色を付ける|Dictionary

同一の表を比較し、値が違うセルに色を付ける|配列

表を比較し、違う(同じ)セルに色を付ける|Dictionary

 

アプリの設定

アプリのトップページ 

 ⇒▼転記・上書き・新規追加・比較

 ⇒通し番号がある2つの表を比較し、違うセルに色を付ける

 

表示されるVBAコード 

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

 

VBAコードを見る

 Sub デモ() '通し番号がある2つの表を比較し、違うセルに色を付ける
 
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False  ' 警告表示を停止
 
'辞書オブジェクトの作成
    Dim 辞書1 As Object, 辞書2 As Object
    Set 辞書1 = CreateObject("Scripting.Dictionary")
    Set 辞書2 = CreateObject("Scripting.Dictionary")
'基準の表を決定
    Sheets("Sheet1").Select
    Dim 最終行 As Long, 対象セル As Range
    最終行 = Cells(Rows.Count, Range("f3").Column).End(xlUp).Row
    Set 対象セル = Range("f3" & ":" & Cells(最終行, Range("i3").Column).Address(False, False))
'辞書1の作成
    Dim key1 As Variant, 行1 As Range
    For Each 行1 In 対象セル.Rows
        key1 =行1.Cells(1, 1)
        If 辞書1.Exists(key1) Then
            行1.Select
            MsgBox "選択した値に重複があるので終了します"
            Exit Sub
        Else
            辞書1(key1) = 行1.cells(1,2) & "|" & 行1.cells(1,3) & "|" & 行1.cells(1,4)
        End If
    Next
'色を付ける表を決定
    Sheets("Sheet1").Select
    Dim 最終行2 As Long
    最終行2 = Cells(Rows.Count, Range("a3").column).End(xlUp).Row
    Set 対象セル = Range( "a3" & ":" & Cells(最終行2, Range("d3").Column).Address(False, False))
'辞書1にkey2
    Dim key2 As Variant, 行2 As Range
    For Each 行2 In 対象セル.Rows
        key2 = 行2.Cells(1, 1)
        '辞書1にkey2が無い
        If Not 辞書1.Exists(key2) Then
            行2.Cells(1, 1).Interior.Color = RGB(255, 255, 0)
        Else
        '辞書1にkey2にがあっても、比較するセルが違う
            辞書2(key2) = 行2.cells(1,2) & "|" & 行2.cells(1,3) & "|" & 行2.cells(1,4)     
            If 辞書1(key2) <> 辞書2(key2) Then
                Dim 要素1 As Variant, 要素2 As Variant
                要素1 = Split(辞書1(key2), "|")
                要素2 = Split(辞書2(key2), "|")
                 If 要素1(0) <> 要素2(0) Then 行2.Cells(1, 2).Interior.Color = RGB(255, 255, 0)  
                 If 要素1(1) <> 要素2(1) Then 行2.Cells(1, 3).Interior.Color = RGB(255, 255, 0)  
                 If 要素1(2) <> 要素2(2) Then 行2.Cells(1, 4).Interior.Color = RGB(255, 255, 0)  
            End If
         End If
    Next        
'Application.ScreenUpdatingとApplication.DisplayAlertsをTrueに戻す
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub   

 

ChatGPTで修正

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

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