Excelはデータを扱うツール。いろいろなデータを表に反映して似たようなデータを照合して比較したい時って結構ありませんか？
２つのデータの差分を一発で色付けしてわかりやすくしたい、そんな機能があったらきっと便利です。
そこで、２シートに比較したいデータを貼り付けし、超絶簡単に大量のデータを比較するVBAマクロを作成してみました。
データベースからデータを取得し、データを解析して差分を抽出したい時なんかは大いに役に立つと思います。
百聞は一見に如かず、一目瞭然、一発でイメージが湧き、使い方がわかるようなGIFアニメ付きです。
個人用マクロなどにコピーして実行するだけなので、ぜひお試しください。
データ差分比較抽出ツールについて
データ比較ツールとしてWinMergeなどの定番ソフトを使えば細かい比較ができます。
それで目的が満たされればよいですが、テキストなので解析がめんどくさいですね。
なかなかExcelでアドインとか使わずに手軽に思い通りに比較できる手段ってないですよね。
VLOOKUP関数や条件付き書式をいちいち使うのも結構大変です。
そこで、Excelで簡単に行、列、セル単位で一発で色で差分を確認できると便利かなぁと思ってマクロを作成してみました。
今回作ったマクロは以下２パターンの比較になります。
①行と列のデータ数が全く同じ前提で全データのセルをすべて比較
②プライマリーキー列指定で１行のデータの有無を含めて比較
作成した比較処理の主なポイントは以下です。なるべくインターフェースを簡単にし、直感で操作できるように目指しました。詳細な仕様はソース上のコメントなどで補足してます。
隣り合わせに並べた２シートに比較データを設定
比較したいデータをそれぞれ２シートに分けて設定します。同じ位置関係で比較しやすくするためです。
プライマリーキーの入力指定有無で比較方法を判断
キー未入力で全行列セル比較、キー列指定でその列をユニークデータと判断して１行データありなしの比較を行います。
行と列のデータ数が全く同じ全データのセルの一致・不一致を差分比較
まずは行列の数が同じデータを２シートに設定して、単純にその値の差分を抽出したい場合に行う方法です。
２シートの行列セル全比較で色を付けて表示する操作イメージ
下記画像にて比較操作のイメージを沸かせてみてください。
テストデータを貼り付けて適当に値をいじって左右の違いを浮き彫りにしてます。
データ数が違う場合は事前にチェックで弾きます。
プライマリーキー列指定で１行の重複データの有無を含めて差分比較
次は行列の数が違っても同じでもよいデータを２シートに設定して、プライマリーキー（一意となる列）を指定して行ごとのデータありなしの違いを含めて差分を抽出したい場合に行う方法です。
２シートのプライマリーキー列指定比較で色を付けて表示する操作イメージ
下記画像にて比較操作のイメージを沸かせてみてください。
テストデータを貼り付けてプライマリーキー列の値をいじって左右の行列の違いを浮き彫りにしてます。
プライマリキーによる重複データは処理中にチェックで弾きます。
左右2シートデータ照合キー差分比較VBAマクロの主な仕様
細かい処理はコメントで補足してますが、ザックリとした仕様を箇条書きで記載します。
概要
- 左右２シートをデータ照合比較し、差分の行やセルに色を付ける。
- 比較方法は「行列セル全比較」と「プライマリーキー列指定比較」の２パターン。
- 元シートを比較用にコピーして処理する。（元シートは一切いじらないので繰り返し可能）
- 比較処理に必要なチェックを実施する。（範囲チェック、重複チェックなど）
前提
- 比較対象２シートの左側シートがアクティブの状態で実行。
- プライマリーキーは数字か英字のみで指定。（複数の場合はカンマ区切り）
- セル全比較の場合は左右シート両方共、行と列が同じである必要がある。
- プライマリーキー列指定比較の場合はそのキーで一意になっている必要がある。
（一意になっていない場合はエラーとし、処理途中で強制終了） - シートを非表示にした状態での実行は非推奨（わけわからなくなる可能性あり）
- セルの表示形式は全セル「文字列」推奨。
- 数式は非推奨（未検証）。※正常に動作するかもしれないが、しないかもしれない。
左右2シートデータ照合キー差分比較VBAマクロのソースコード
差分比較でデータ解析効率を爆上げしたい方は、下記のソースコードを以下↓↓↓のリンクの内容に従って個人用マクロにコピーしてご使用ください。
【Excel】超便利な個人用マクロブックにVBAを記録追加作成して実行【初心者も簡単】
仕事や勉強を行う上で、Excelを使用するならば、絶対に知っておいた方がよい「個人用マクロブックの設定方法」をまとめました。マクロを頻繁に使用する人、今まで「作業中のブック」のみに個別設定していた人は、自分の作業に合った共通処理の...
caymezon.com
2019.03.10
マクロならば、痒いところに手が届きます。用途によっては目的に沿わない可能性がありますが、Const値を持たせてなるべく汎用的に作成しています。
自分に合った方法にカスタマイズしてみてください。VBAマクロの勉強にも少しは役立つと思います。
結果的に割と複雑な処理になってしまったので、もし何かバグっていたらごめんなさい。気付いたら改修します。
Sub 左右2シートデータ照合キー差分比較()
Const 確認メッセージフラグ = 1 '0:確認メッセージを表示しない、1:確認メッセージを表示する
Const タイトル有無フラグ = 1 '0:タイトルなし、1:タイトルあり
Const 結果シートマージフラグ = 1 '0:マージしない、1:マージする
Call 左右2シートデータ照合キー差分比較処理(確認メッセージフラグ _
, タイトル有無フラグ _
, 結果シートマージフラグ)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub 左右2シートデータ照合キー差分比較処理(確認メッセージフラグ As Integer _
, タイトル有無フラグ As Integer _
, 結果シートマージフラグ As Integer)
''''''''''概要''''''''''
'・左右２シートをデータ照合比較し、差分の行やセルに色を付ける。
'・比較方法は「行列セル全比較」と「プライマリーキー列指定比較」の２パターン。
'・元シートを比較用にコピーして処理する。（元シートは一切いじらないので繰り返し可能）
'・比較処理に必要なチェックを実施する。（範囲チェック、重複チェックなど）
''''''''''前提''''''''''
'・比較対象２シートの左側シートがアクティブの状態で実行。
'・プライマリーキーは数字か英字のみで指定。（複数の場合はカンマ区切り）
'・セル全比較の場合は左右シート両方共、行と列が同じである必要がある。
'・プライマリーキー列指定比較の場合はそのキーで一意になっている必要がある。
' （一意になっていない場合はエラーとし、処理途中で強制終了）
'・シートを非表示にした状態での実行は非推奨（わけわからなくなる可能性あり）
'・セルの表示形式は全セル「文字列」推奨。
'・数式は非推奨（未検証）。※正常に動作するかもしれないが、しないかもしれない。
''''''''''定義''''''''''
Dim 実行確認 As Integer
Dim メッセージ As String
Dim 比較処理区分 As Integer
'1:データ数が全く同じ前提で行列セル全比較、2:プライマリーキー列指定で比較
'元シート
Dim 左シート, 右シート As Object '元シート
Dim 左データ範囲, 右データ範囲 As Range '比較データ範囲
Dim 左シート番号, 右シート番号 As Integer '左右シート番号
Dim 左シート名, 右シート名 As String '左右シート名
'比較シート
Dim 左比較シート, 右比較シート As Object '比較用コピーシート
Dim 左比較シート番号, 右比較シート番号 As Integer 'コピー後のシート番号
Dim 左比較シート名, 右比較シート名 As String 'コピー後のシート名
Dim 現在時刻 As String 'コピー後シート名をユニークにするための時刻
'行列編集
Dim 左現在行, 右現在行 As Long
Dim 左キー列, 右キー列 As Range
Dim 左開始行, 右開始行, 左開始列, 右開始列 As Long
Dim 左最終行, 右最終行, 左最終列, 右最終列 As Long
Dim 比較開始行, 比較開始列, 比較最終行, 比較列数 As Long
Dim 比較最終列 As Long '※１
Dim 比較対象行, 比較対象列 As Long '値比較時ワーク
Dim 左キー列セル範囲, 右キー列セル範囲 As Range 'キー列のセル範囲
Dim ソート開始行, 列位置追加行 As Long
Dim 差分列, キー列, 追加列数 As Integer '編集列
'キー列編集
Dim 左キー, 右キー, キー値 As String 'ユニークとなるキー値
Dim キー列入力値, キー列数字編集値, キー列英字編集値 As String 'キー配列編集値
Dim キー列変換 As String
Dim 入力キー数字列 As Long '※１
Dim 入力キー英字列 As String '※１
Dim キー列番号配列 As Variant 'プライマリーキー配列
Dim 左キー重複フラグ, 右キー重複フラグ As Boolean
Dim キー列ワーク配列() As Integer
Dim 左差分セル, 右差分セル, 左比較セル, 右比較セル As Range '各比較セル範囲
'カウンタ
Dim i As Long '※１
Dim j As Long
'※１：「ByRef引数の型が一致しません。」回避のため単一定義
''''''''''高速化''''''''''
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
''''''''''初期処理''''''''''
'比較シート設定
左シート番号 = ActiveSheet.index '現在のアクティブシートを基点にIndex決定
If 左シート番号 = Worksheets.Count Then
MsgBox "比較対象の左側を現在シートにして実行してください。（右隣りシートあり前提）" & vbCrLf _
& "処理を終了します。"
Exit Sub
End If
右シート番号 = 左シート番号 + 1
左シート名 = Sheets(左シート番号).name
右シート名 = Sheets(右シート番号).name
Set 左シート = Sheets(左シート名)
Set 右シート = Sheets(右シート名)
'比較対象データ範囲
Set 左データ範囲 = 左シート.UsedRange
':上下
左開始行 = 左データ範囲.Row
左最終行 = 左データ範囲.Row + 左データ範囲.Rows.Count - 1
':左右
左開始列 = 左データ範囲.Column
左最終列 = 左データ範囲.Column + 左データ範囲.Columns.Count - 1
Set 右データ範囲 = 右シート.UsedRange
':上下
右開始行 = 右データ範囲.Row
右最終行 = 右データ範囲.Row + 右データ範囲.Rows.Count - 1
':右右
右開始列 = 右データ範囲.Column
右最終列 = 右データ範囲.Column + 右データ範囲.Columns.Count - 1
''''''''''チェック''''''''''
'''''開始行チェック'''''
'開始行が左右で同じか
If 左開始行 <> 右開始行 Then
MsgBox "「" & 左シート名 & "」シートと「" & 右シート名 & "」シートの開始行が違います。" _
& "合わせてください。" & vbCrLf _
& "処理を終了します。"
Exit Sub
Else
比較開始行 = 左開始行 '比較を開始する行を確定
End If
'''''開始列チェック'''''
'1列目(A列)から設定しているか
If 左開始列 <> 1 Or 右開始列 <> 1 Then
MsgBox "「" & 左シート名 & "」シートと「" & 右シート名 & "」シート共に" _
& "1列目(A列)から比較データを設定してください。" & vbCrLf _
& "処理を終了します。"
Exit Sub
Else
比較開始列 = 左開始列 '比較を開始する行を確定
End If
'''''最終列チェック'''''
'最終列が左右で同じか
If 左最終列 <> 右最終列 Then
右シート.Activate
右データ範囲.Select
左シート.Activate
左データ範囲.Select
MsgBox "「" & 左シート名 & "」シートと「" & 右シート名 & "」シートのデータ最終列が違います。" _
& "合わせてください。" & vbCrLf _
& "処理を終了します。"
Exit Sub
Else
比較最終列 = 左最終列
比較列数 = 比較最終列 - 比較開始列 + 1
End If
'''''キー列入力'''''
キー列入力値 = Application.InputBox( _
"未入力：行列セル全比較" & vbCrLf _
& "列番号指定(カンマ区切り)：プライマリーキー比較" _
, Type:=2 _
, Default:="")
If キー列入力値 = "" Then
比較処理区分 = 1 'キー入力なしの場合は行列セル全比較
'全列取得
ReDim キー列ワーク配列(比較列数)
For i = 1 To 比較列数
キー列入力値 = キー列入力値 & i & ","
キー列ワーク配列(i) = i
Next
'キー列入力値 = left(キー列入力値, InStrRev(キー列入力値, ",") - 1) '最後のカンマをカット
キー列入力値 = "1-" & 比較列数
キー列英字編集値 = "A-" & A1式変換(比較列数) '数字→英字(1→A)変換
キー列番号配列 = キー列ワーク配列
ElseIf キー列入力値 = False Then
Exit Sub 'Escキャンセルの場合は終了
ElseIf キー列入力値 <> "" Then
比較処理区分 = 2 'キー入力ありの場合はプライマリーキー列指定比較
'キー入力値取得（全角変換、半角スペース除去）
キー列番号配列 = Split(Replace(StrConv(キー列入力値, vbNarrow), " ", ""), ",")
ReDim キー列ワーク配列(UBound(キー列番号配列))
'キー列入力値編集
For i = LBound(キー列番号配列) To UBound(キー列番号配列)
If Not キー列番号配列(i) Like "*[!0-9]*" Then '数字のみかチェック
入力キー数字列 = キー列番号配列(i)
入力キー英字列 = A1式変換(入力キー数字列) '数字→英字(1→A)変換
キー列数字編集値 = キー列数字編集値 & 入力キー数字列 & ","
キー列英字編集値 = キー列英字編集値 & 入力キー英字列 & ","
ElseIf Not キー列番号配列(i) Like "*[!a-zA-Z]*" Then '英字のみかチェック
入力キー英字列 = キー列番号配列(i)
入力キー数字列 = R1C1式変換(入力キー英字列) '英字→数字(A→1)変換
キー列数字編集値 = キー列数字編集値 & 入力キー数字列 & ","
キー列英字編集値 = キー列英字編集値 & 入力キー英字列 & ","
Else
MsgBox "キー列を数字または英字で入力してください。" & vbCrLf _
& "処理を終了します。"
Exit Sub
End If
'キー入力チェック
'入力した列がデータ範囲を超えていないか
If 比較最終列 < 入力キー数字列 Then
MsgBox "入力キー列「" & A1式変換(入力キー数字列) & "列(" & 入力キー数字列 & ")」が" _
& "データ範囲の最終列「" & A1式変換(比較最終列) & "列(" & 比較最終列 & ")」を" _
& "超えてます。" & vbCrLf _
& "処理を終了します。"
Exit Sub
End If
Next
キー列数字編集値 = left(キー列数字編集値, InStrRev(キー列数字編集値, ",") - 1) '最後のカンマをカット
キー列英字編集値 = left(キー列英字編集値, InStrRev(キー列英字編集値, ",") - 1) '最後のカンマをカット
キー列入力値 = キー列数字編集値
キー列番号配列 = Split(キー列入力値, ",")
End If
'''''最終行チェック'''''
'最終行が左右で同じか（行列セル全比較のみ）
If 比較処理区分 = 1 Then
If 左最終行 <> 右最終行 Then
MsgBox "「" & 左シート名 & "」シートと「" & 右シート名 & "」シートのデータ行の数が違います。" _
& "合わせてください。" & vbCrLf _
& "（行列データ数が全く同じ前提で比較します）" & vbCrLf _
& "処理を終了します。"
Exit Sub
Else
比較最終行 = 左最終行
End If
End If
''''''''''確認処理''''''''''
If 確認メッセージフラグ = 1 Then
If 比較処理区分 = 1 Then '行列セル全比較の場合
メッセージ = メッセージ _
& "・行列データ数が全く同じ前提で、行列セル全データを比較します。" & vbCrLf _
& vbCrLf
ElseIf 比較処理区分 = 2 Then 'プライマリーキー列指定比較の場合
メッセージ = メッセージ _
& "・プライマリーキー列でソートし、左右データ存在チェックを含めて比較します。" & vbCrLf
If タイトル有無フラグ = 1 Then
メッセージ = メッセージ _
& "（データ開始行をタイトル行として比較します。タイトル行はソート対象外です。）" & vbCrLf _
& vbCrLf
Else
メッセージ = メッセージ _
& "（全データ行を全てキーでソートして比較します。）" & vbCrLf _
& vbCrLf
End If
End If
メッセージ = メッセージ _
& "・「" & 左シート名 & "」シート(" & 左最終行 & "行目まで)と" _
& "「" & 右シート名 & "」シート(" & 右最終行 & "行目まで)を" & vbCrLf _
& " データ比較します。" & vbCrLf _
& "・「A列(1)～「" & A1式変換(比較最終列) & "列(" & 比較最終列 & ")」を比較対象とします。" & vbCrLf _
& "・比較用に左右それぞれコピーして新規シートで比較します。" & vbCrLf _
& "・「" & キー列入力値 & "」列目、「" & キー列英字編集値 & "」列のデータをキー値として" & vbCrLf _
& " データ比較します。" & vbCrLf
'実行確認
If メッセージ <> "" Then
実行確認 = MsgBox(メッセージ & vbCrLf _
& "実行してよろしいですか？", vbYesNo + vbQuestion)
If 実行確認 = vbNo Then Exit Sub
End If
End If
''''''''''比較用シートコピー''''''''''
左比較シート番号 = 右シート番号 + 1
右比較シート番号 = 左比較シート番号 + 1
現在時刻 = Format(Now, "hhnnss") '現在時刻（時分秒）
'比較対象左側シートをコピーして比較編集対象とする
左シート.Copy After:=Sheets(左シート番号 + 1)
'シート名が24文字以下だったら"_hhnnss"(7文字)を付加
If Len(左シート名) <= 24 Then
左比較シート名 = 左シート名 + "_" + 現在時刻
Else
左比較シート名 = left(左シート名, 24) + "_" + 現在時刻
End If
Sheets(左比較シート番号).name = 左比較シート名
Set 左比較シート = Sheets(左比較シート名)
左比較シート.Tab.Color = RGB(255, 153, 204) '38:ローズ
'比較対象右側シートをコピーして比較編集対象とする
Sheets(右シート番号).Copy After:=Sheets(右シート番号 + 1)
If Len(左シート名) <= 24 Then
右比較シート名 = 右シート名 + "_" + 現在時刻
Else
右比較シート名 = Sheets(右シート番号).name + "_" + 現在時刻
End If
Sheets(右比較シート番号).name = 右比較シート名
Set 右比較シート = Sheets(右比較シート名)
右比較シート.Tab.Color = RGB(0, 204, 255) '33:スカイブルー
''''''''''左比較シートと右比較シートに編集列挿入''''''''''
差分列 = 1 '１列目固定
キー列 = 2 '２列目固定
追加列数 = 2
左比較シート.Columns(差分列).Insert ' 差分列挿入
右比較シート.Columns(差分列).Insert ' 差分列挿入
左比較シート.Columns(キー列).Insert ' キー列挿入
右比較シート.Columns(キー列).Insert ' キー列挿入
''''''''''左比較シートと右比較シートにキー値セット''''''''''
'''''左比較シート'''''
左比較シート.Activate
Set 左キー列セル範囲 = Range(cells(比較開始行, キー列), cells(左最終行, キー列))
For Each 左キー列 In 左キー列セル範囲
左キー = ""
For i = LBound(キー列番号配列) To UBound(キー列番号配列)
キー値 = cells(左キー列.Row, 追加列数 + キー列番号配列(i)).Text '表示上の値を比較するのでText取得
左キー = 左キー & キー値
Next
If 左キー = "" Then 左キー = "null" '空文字の扱いはめんどくさいので"null"にしておく
cells(左キー列.Row, キー列).Value = 左キー
cells(左キー列.Row, キー列).Font.Bold = True '太字
cells(左キー列.Row, キー列).Font.Underline = True '下線
Next
'''''右比較シート'''''
右比較シート.Activate
Set 右キー列セル範囲 = Range(cells(比較開始行, キー列), cells(右最終行, キー列))
For Each 右キー列 In 右キー列セル範囲
右キー = ""
For i = LBound(キー列番号配列) To UBound(キー列番号配列)
キー値 = cells(右キー列.Row, 追加列数 + キー列番号配列(i)).Text '表示上の値を比較するのでText取得
右キー = 右キー & キー値
Next
If 右キー = "" Then 右キー = "null" '空文字の扱いはめんどくさいので"null"にしておく
cells(右キー列.Row, キー列).Value = 右キー
cells(右キー列.Row, キー列).Font.Bold = True '太字
cells(右キー列.Row, キー列).Font.Underline = True '下線
Next
If 比較処理区分 = 1 Then
'データ数が全く同じ前提で行列セル全比較
左比較シート.Activate
左現在行 = 比較開始行 '左開始データ行
右現在行 = 比較開始行 '右開始データ行
左キー = 左比較シート.cells(左現在行, キー列).Value
右キー = 右比較シート.cells(右現在行, キー列).Value
Do Until 左キー = "" And 右キー = "" '左キーと右キーが両方共、ブランクになった場合終了
'行の照合（１行ずつキー値で全行を照合）
If 左キー = 右キー Then
'左比較シートのキーと右比較シートのキーが一致の場合
左比較シート.cells(左現在行, 差分列).Value = "一致"
右比較シート.cells(右現在行, 差分列).Value = "一致"
左比較シート.cells(左現在行, 差分列).Font.Color = RGB(0, 128, 0) '10:緑
右比較シート.cells(右現在行, 差分列).Font.Color = RGB(0, 128, 0) '10:緑
Else
'左比較シートのキーと右比較シートのキーが不一致の場合
左比較シート.cells(左現在行, 差分列).Value = "不一致"
右比較シート.cells(右現在行, 差分列).Value = "不一致"
左比較シート.cells(左現在行, 差分列).Font.Color = RGB(153, 204, 0) '43:ライム
右比較シート.cells(右現在行, 差分列).Font.Color = RGB(153, 204, 0) '43:ライム
End If
'行カウント
左現在行 = 左現在行 + 1
右現在行 = 右現在行 + 1
'次のキー値
左キー = 左比較シート.cells(左現在行, キー列).Value
右キー = 右比較シート.cells(右現在行, キー列).Value
Loop
ElseIf 比較処理区分 = 2 Then
'プライマリーキー列指定で比較
''''''''''左比較シートと右比較シートをソート''''''''''
If タイトル有無フラグ = 1 Then
ソート開始行 = 比較開始行 + 1
Else
ソート開始行 = 比較開始行
End If
'''''左比較シート'''''
左比較シート.Activate
左比較シート.Range(cells(ソート開始行, キー列), cells(左最終行, キー列 + 左最終列)).Sort _
Key1:=Columns(キー列), Order1:=xlAscending, Header:=xlNo
'''''右比較シート'''''
右比較シート.Activate
右比較シート.Range(cells(ソート開始行, キー列), cells(右最終行, キー列 + 右最終列)).Sort _
Key1:=Columns(キー列), Order1:=xlAscending, Header:=xlNo
''''''''''左比較シートと右比較シートのソート後データチェック''''''''''
'''''左比較シート'''''
左比較シート.Activate
Set 左キー列セル範囲 = Range(cells(比較開始行, キー列), cells(左最終行, キー列))
For Each 左キー列 In 左キー列セル範囲
左キー = cells(左キー列.Row, キー列).Value
If 左キー = cells(左キー列.Row, キー列).Offset(1, 0).Value Then
左キー重複フラグ = True
Exit For
End If
Next
If 左キー重複フラグ Then
cells(左キー列.Row, キー列).Interior.Color = RGB(255, 0, 0) '3:赤
cells(左キー列.Row, キー列).Offset(1, 0).Interior.Color = RGB(255, 0, 0) '3:赤
cells(左キー列.Row, キー列).Select
MsgBox "「" & 左シート名 & "」シートのキー列「" & キー列入力値 & "」データ、" _
& 左キー列.Row & "行目の値「" & 左キー & "」で重複してます。" & vbCrLf _
& "途中ですが、処理を終了します。" & vbCrLf _
& "キー比較はできませんので設定データを見直してください。"
Exit Sub
End If
'''''右比較シート'''''
右比較シート.Activate
Set 右キー列セル範囲 = Range(cells(比較開始行, キー列), cells(右最終行, キー列))
For Each 右キー列 In 右キー列セル範囲
右キー = cells(右キー列.Row, キー列).Value
If 右キー = cells(右キー列.Row, キー列).Offset(1, 0).Value Then
右キー重複フラグ = True
Exit For
End If
Next
If 右キー重複フラグ Then
cells(右キー列.Row, キー列).Interior.Color = RGB(255, 0, 0) '3:赤
cells(右キー列.Row, キー列).Offset(1, 0).Interior.Color = RGB(255, 0, 0) '3:赤
cells(右キー列.Row, キー列).Select
MsgBox "「" & 右シート名 & "」シートのキー列「" & キー列入力値 & "」データ、" _
& 右キー列.Row & "行目の値「" & 右キー & "」で重複してます。" & vbCrLf _
& "途中ですが、処理を終了します。" & vbCrLf _
& "キー比較はできませんので設定データを見直してください。"
Exit Sub
End If
''''''''''左比較シートと右比較シートをキー値で照合''''''''''
左比較シート.Activate
If タイトル有無フラグ = 1 Then 'タイトルありの場合は２行目から
左現在行 = 比較開始行 + 1
右現在行 = 比較開始行 + 1
Else
左現在行 = 比較開始行
右現在行 = 比較開始行
End If
左キー = 左比較シート.cells(左現在行, キー列).Value
右キー = 右比較シート.cells(右現在行, キー列).Value
Do Until 左キー = "" And 右キー = "" '左キーと右キーが両方共、ブランクになった場合終了
'行の照合（１行ずつキー値で照合して足りない場合は行挿入）
If 左キー = 右キー Then
'左比較シートのキーと右比較シートのキーが一致した場合
左比較シート.cells(左現在行, 差分列).Value = "一致"
右比較シート.cells(右現在行, 差分列).Value = "一致"
左比較シート.cells(左現在行, 差分列).Font.Color = RGB(0, 128, 0) '10:緑
右比較シート.cells(右現在行, 差分列).Font.Color = RGB(0, 128, 0) '10:緑
ElseIf 左キー > 右キー Then
If 右キー <> "" Then
'左比較シートのキーの方が右比較シートのキーより大きい場合
左比較シート.Rows(左現在行).Insert
左比較シート.cells(左現在行, 差分列).Value = "なし"
左比較シート.cells(右現在行, キー列).Value = 右キー
左比較シート.cells(左現在行, 差分列).Font.Color = RGB(255, 0, 0) '3:赤
右比較シート.cells(右現在行, 差分列).Value = "あり"
右比較シート.cells(右現在行, 差分列).Font.Color = RGB(0, 0, 255) '5:青
Else
'左比較シートのキーがまだあるにも関わらず、右比較シートのキーが最後まで到達した場合
右比較シート.Rows(右現在行).Insert
右比較シート.cells(右現在行, 差分列).Value = "なし"
右比較シート.cells(右現在行, キー列).Value = 左キー
右比較シート.cells(右現在行, 差分列).Font.Color = RGB(255, 0, 0) '3:赤
左比較シート.cells(左現在行, 差分列).Value = "あり"
左比較シート.cells(左現在行, 差分列).Font.Color = RGB(0, 0, 255) '5:青
End If
ElseIf 左キー < 右キー Then
If 左キー <> "" Then
'右比較シートのキーの方が左比較シートのキーより大きい場合
右比較シート.Rows(右現在行).Insert
右比較シート.cells(右現在行, 差分列).Value = "なし"
右比較シート.cells(右現在行, キー列).Value = 左キー
右比較シート.cells(右現在行, 差分列).Font.Color = RGB(255, 0, 0) '3:赤
左比較シート.cells(左現在行, 差分列).Value = "あり"
左比較シート.cells(左現在行, 差分列).Font.Color = RGB(0, 0, 255) '5:青
Else
'右比較シートのキーがまだあるにも関わらず、左比較シートのキーが最後まで到達した場合
左比較シート.Rows(左現在行).Insert
左比較シート.cells(左現在行, 差分列).Value = "なし"
左比較シート.cells(右現在行, キー列).Value = 右キー
左比較シート.cells(左現在行, 差分列).Font.Color = RGB(255, 0, 0) '3:赤
右比較シート.cells(右現在行, 差分列).Value = "あり"
右比較シート.cells(右現在行, 差分列).Font.Color = RGB(0, 0, 255) '5:青
End If
End If
'行カウント
左現在行 = 左現在行 + 1
右現在行 = 右現在行 + 1
'次のキー値
左キー = 左比較シート.cells(左現在行, キー列).Value
右キー = 右比較シート.cells(右現在行, キー列).Value
Loop
End If
'値比較 ※データ照合済（行数の同期が取れている）前提
比較最終行 = 左比較シート.cells(Rows.Count, 差分列).End(xlUp).Row
For 比較対象行 = 比較開始行 To 比較最終行
For 比較対象列 = 追加列数 + 比較開始列 To 追加列数 + 比較最終列 '差分列＋キー列を含む
Set 左差分セル = 左比較シート.cells(比較対象行, 差分列)
Set 右差分セル = 右比較シート.cells(比較対象行, 差分列)
Set 左比較セル = 左比較シート.cells(比較対象行, 比較対象列)
Set 右比較セル = 右比較シート.cells(比較対象行, 比較対象列)
If 左差分セル.Value = "なし" And 右差分セル.Value = "あり" Then
'左比較シートが「不足」で右比較シートが「追加」の場合
左比較セル.Interior.Color = RGB(255, 153, 204) '38:ローズ
右比較セル.Interior.Color = RGB(0, 204, 255) '33:スカイブルー
ElseIf 左差分セル.Value = "あり" And 右差分セル.Value = "なし" Then
'左比較シートが「追加」で右比較シートが「不足」の場合
左比較セル.Interior.Color = RGB(0, 204, 255) '33:スカイブルー
右比較セル.Interior.Color = RGB(255, 153, 204) '38:ローズ
Else
'左右比較シートが不一致の場合
If 左比較セル.Text <> 右比較セル.Text Then
'同じ位置のセルの値が等しくなければ、そのセルを色付け。
左比較セル.Interior.Color = RGB(255, 255, 153) '36:薄い黄
右比較セル.Interior.Color = RGB(255, 255, 153) '36:薄い黄
'差分を不一致に書き換え
左差分セル.Value = "不一致"
左差分セル.Font.Color = RGB(153, 204, 0) '43:ライム
右差分セル.Value = "不一致"
右差分セル.Font.Color = RGB(153, 204, 0) '43:ライム
Else
'同じ位置のセルの値が等しければ、何もしない
End If
End If
Next
Next
''''''''''追加編集''''''''''
'''''追加列編集'''''
左比較シート.Range(左比較シート.cells(比較開始行, 差分列), 左比較シート.cells(比較最終行, 差分列)) _
.Borders(xlEdgeRight).LineStyle = xlContinuous '右罫線追加
右比較シート.Range(右比較シート.cells(比較開始行, 差分列), 右比較シート.cells(比較最終行, 差分列)) _
.Borders(xlEdgeRight).LineStyle = xlContinuous '右罫線追加
'''''追加行編集'''''
'元のシートの列情報を追加するために比較データの１つ上に１行追加
左比較シート.Rows(比較開始行).Insert
右比較シート.Rows(比較開始行).Insert
'列情報を追加（キー列は下線と太字付加）
列位置追加行 = 比較開始行
For i = 1 To 比較列数
If Application.ReferenceStyle = xlA1 Then
'A1式の場合
キー列変換 = A1式変換(i)
Else
'R1C1式の場合
キー列変換 = i
End If
左比較シート.cells(列位置追加行, 追加列数 + i).Value = キー列変換
右比較シート.cells(列位置追加行, 追加列数 + i).Value = キー列変換
For j = LBound(キー列番号配列) To UBound(キー列番号配列)
If i = キー列番号配列(j) Then
With 左比較シート.cells(列位置追加行, 追加列数 + i).Font
'.Underline = True '下線
.Bold = True '太字
End With
With 右比較シート.cells(列位置追加行, 追加列数 + i).Font
'.Underline = True '下線
.Bold = True '太字
End With
Exit For
End If
Next
Next
'''''その他編集'''''
'枠線やシート名設定など
左比較シート.Activate
With Range(cells(列位置追加行, 比較開始列 + 追加列数), cells(列位置追加行, 比較最終列 + 追加列数))
.Borders(xlEdgeBottom).LineStyle = xlContinuous '下罫線追加
.Interior.Color = RGB(255, 153, 204) '38:ローズ
.HorizontalAlignment = xlCenter '横位置を中央揃え
End With
With cells(列位置追加行, 差分列)
.Value = 左シート名
.Font.Bold = True '太字
End With
'行フィルタとウィンドウ枠を固定
If タイトル有無フラグ = 1 Then
Range(cells(列位置追加行 + 1, 差分列), cells(列位置追加行 + 1, 比較最終列 + 追加列数)).AutoFilter
Rows(列位置追加行 + 2).Select
Else
Range(cells(列位置追加行, 差分列), cells(列位置追加行, 比較最終列 + 追加列数)).AutoFilter
Rows(列位置追加行 + 1).Select
End If
ActiveWindow.FreezePanes = True 'ウィンドウ枠を固定
右比較シート.Activate
With Range(cells(列位置追加行, 比較開始列 + 追加列数), cells(列位置追加行, 比較最終列 + 追加列数))
.Borders(xlEdgeBottom).LineStyle = xlContinuous '下罫線追加
.Interior.Color = RGB(0, 204, 255) '33:スカイブルー
.HorizontalAlignment = xlCenter '横位置を中央揃え
End With
With cells(列位置追加行, 差分列)
.Value = 右シート名
.Font.Bold = True '太字
End With
'行フィルタとウィンドウ枠を固定
If タイトル有無フラグ = 1 Then
Range(cells(列位置追加行 + 1, 差分列), cells(列位置追加行 + 1, 比較最終列 + 追加列数)).AutoFilter
Rows(列位置追加行 + 2).Select
Else
Range(cells(列位置追加行, 差分列), cells(列位置追加行, 比較最終列 + 追加列数)).AutoFilter
Rows(列位置追加行 + 1).Select
End If
ActiveWindow.FreezePanes = True 'ウィンドウ枠を固定
'キー列は最後に削除（何かバグってたらまずはコレをコメントアウト）
左比較シート.Columns(キー列).Delete
右比較シート.Columns(キー列).Delete
'セル選択
右比較シート.Activate
右比較シート.Range("A1").Select
左比較シート.Activate
左比較シート.Range("A1").Select
'''''結果マージ'''''
'左右の比較結果を１シートにマージ
If 結果シートマージフラグ Then
'右シートの結果を左シートにコピー
右比較シート.Range(右比較シート.Columns(1), 右比較シート.Columns(比較最終列 + 1)).Copy
左比較シート.Paste Destination:=左比較シート.Columns(比較最終列 + 2)
Application.CutCopyMode = False
左比較シート.Activate
Range(cells(列位置追加行, 比較最終列 + 1), cells(比較最終行 + 1, 比較最終列 + 1)) _
.Borders(xlEdgeRight).LineStyle = xlDouble '右罫線追加(二重線)
'行フィルタを一旦解除して再設定
If タイトル有無フラグ = 1 Then
Range(cells(列位置追加行 + 1, 差分列), cells(列位置追加行 + 1, 比較最終列 + 1)).AutoFilter
Range(cells(列位置追加行 + 1, 差分列), cells(列位置追加行 + 1, (比較最終列 + 1) * 2)).AutoFilter
Else
Range(cells(列位置追加行, 差分列), cells(列位置追加行, 比較最終列 + 1)).AutoFilter
Range(cells(列位置追加行, 差分列), cells(列位置追加行, (比較最終列 + 1) * 2)).AutoFilter
End If
'シート名が24文字以下だったら"_hhnnss"(7文字)を付加
If Len(左シート名 & "_" & 右シート名) <= 24 Then
左比較シート名 = 左シート名 & "_" & 右シート名 + "_" + 現在時刻
Else
左比較シート名 = left(左シート名 & "_" & 右シート名, 24) + "_" + 現在時刻
End If
Sheets(左比較シート番号).name = 左比較シート名
左比較シート.Tab.Color = RGB(153, 204, 0) '43:ライム
'シート削除
Application.DisplayAlerts = False
右比較シート.Delete
Application.DisplayAlerts = True
'セル選択
左比較シート.Activate
左比較シート.Range("A1").Select
End If
'高速化対応
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function A1式変換(col As Long) As String
If col <= 0 Then
A1式変換 = ""
ElseIf col <= 26 Then
A1式変換 = Chr(65 + ((col - 1) Mod 26))
ElseIf col <= 26 * 27 Then
A1式変換 = Chr(65 + ((col - 27) \ 26) Mod 26) & _
Chr(65 + ((col - 1) Mod 26))
ElseIf col <= 26 * 27 * 27 Then
A1式変換 = Chr(65 + ((col - 27 * 27) / 26 \ 26)) & _
Chr(65 + ((col - 27) \ 26) Mod 26) & _
Chr(65 + ((col - 1) Mod 26))
Else
A1式変換 = ""
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function R1C1式変換(ByVal Alpha As String) As Long
R1C1式変換 = 0
If Len(Alpha) = 1 Then
R1C1式変換 = Asc(Alpha) Mod 32
Exit Function
End If
Dim UnicodeArray() As Byte: UnicodeArray = Alpha
Dim i As Long
For i = LBound(UnicodeArray) To UBound(UnicodeArray) Step 2
R1C1式変換 = R1C1式変換 * 26 + (UnicodeArray(i) Mod 32)
Next
End Function
実行方法
「左右2シートをデータ照合キー比較()」を実行してください。
デフォルトはタイトルあり、比較結果マージの設定になってますが、目的に応じてカスタマイズしてください。
最後に
Excelの使い方は人それぞれ、いろんなやり方があると思いますが、一例としてご紹介させていただきました。
ExcelVBAマクロはちょっとした向上心さえあれば、取っ付きやすいプログラムなのでショートカットキーなどと組み合わせてぜひ活用してみてください。
Excel全ショートカットキー一覧はこちら↓↓↓
Excelの使い方や機能がわかるショートカットキー全まとめ一覧【初心者こそ必見】
表計算ソフトとして王者であるExcel。たくさんの人が使っていると思います。まぁまぁ高額ではありますが、その分、高機能なので使い倒したいとは思いませんか？単に表データを扱うだけではなく、図を挿入できたり、設計書などのドキュ...
caymezon.com
2019.04.01
ちょっと工夫すれば、ちょっとした操作に１分かかっていた作業を１０秒でこなすことができるようになる可能性があります。
それだけでも、積み上げれば相当の工数を削減できるはずなので、ぜひ自分に合ったやり方を模索していきましょう。
コメント