エクセル2つのブック列の比較 VBAや関数について

質問

Aと言うブックとBと言うブックがあるとして、

Aのブックは共有ファイルではなく、Zサーバー上にあるエクセルファイルです。

Aのブックに色々な人が行の挿入、商品名の書き換え等をしていて、いつ挿入されたのかが分からないため、VBAや関数を使って調べたいのですが、

Aのブックは10シートあり、サイズ別で行も並べられているため、新しい情報を特定するのが困難です。

BのブックはAと同じシート名を作り、必要箇所だけコピーしているデータです。（オリジナルブック）

やりたいことは、Aのブックから探してBのブックに追加されていない情報、一致していない情報があれば、色を付けてわかりやすくするか、Bのブックの新しいシートに結果を出すようなことがしたいのですが、可能でしょうか？

AのブックはA列-IC列まであるのですが、必要な部分は全シートB列（商品コード）とE列（商品名）のみです。

Bのブックには同じシート名にして、A列に商品コード、B列に商品名としております。

AのブックのB列、E列を参照して、BのブックのA列、B列になければ、結果を表示したいです。

もし出来る方法があれば、教えてほしいです。

今はシートごとに左右比較して、見ていってるのですが、10シートの中に、行数は2000行くらいあるため、それで半日おわってしまいます。

もし分かるかた、マクロを組める方がいれば教えて頂きたいです。宜しくお願い致します。

回答No.6

eden3616 · ベストアンサー

>毎日Aのブックを読み取り専用で開いていて、Bブックも開いた状態で仕事の都合上していてるのですが、それは大丈夫でしょうか？

出来れば入れ替えた方が良いです（重複して開いた場合のチェック処理を追加しております）。
説明ではBを開かずとは書きましたが、Bを開いて利用しても正常に動作するように作っております。

>1シートづつ、赤色部分を探していくのは少し大変ですが、これはしていかないとダメですね。

cnt = msg(cnt, "シート=" & .Name & " / 検索セル[値]=" & c1 & j & "[" & .Range(c1 & j) & "]")

の次に以下を追加してください。

ActiveSheet.Hyperlinks.Add Anchor:=ThisWorkbook.ActiveSheet.Range("A" & cnt) _
, Address:="#'[" & aobj.Name & "]" & .Name & "'!" & .Range(c1 & j).Address

一覧で表示されたセルにリンクが貼られます。
挿入されたリンクをクリックするとAシートの該当セル（着色されたセル）へ飛びます。

お礼

すごいわかりやすいです！！これを元にBブックにそのシートの部分を追加していきます！！

助かりました！！

こんなことがVBAで出来ることも知りませんでした。

神業ですね、なんでも出来るのかなと思ってしまいました。

本当に本当にありがとうございました！！！！

色々細かいことまで、お付き合いして頂いてありがとうございました。

注文が多くてすいませんでした、もう少し早くから質問してれば良かったです。

すごく良い人に教えて頂いて感謝です★

回答No.5

eden3616

>元となるAブックは、サーバー上にあるブックで、パスワードがついているブックなので、読み取りで常にデスクトップ上に開いている状態なので、元々開いているブックに色をつけると言うことはできますか？本当に何度もすいません。

No4の修正は全て適用したうえで以下の仕様に変更しました。

(1)初めにAブック、Bブックを開くダイアログが表示されます（最初と変わっていません）。
　→この処理は実際にファイルが開くわけではなく、プログラムに対象のブックを教えているだけになります。
(2)開こうとしたブックが既に開かれていた場合は、該当のブックを対象とします。
(3)開かれていなかった場合はマクロから開いたうえで対象とします。

パスのかかっている読み取り専用のAブックを開いたうえで実行してください。
指定したBブックが開いて処理が行われるようになります。
（フォームなどを表示して現在開いているブックの一覧を表示、対象の選択を促す等も出来ますが、
フォームを作成・追加して頂く必要がありますので(1)の方法を利用しております）

以下のコードを全て入れ替えてご利用ください。

Sub 実行()
Dim afile As String, bfile As String
Dim aobj As Object, bobj As Object
Dim i As Long
Dim cnt As Integer
Dim allbooks As Workbook
achk = "B,E"
bchk = "A,B"
afile = Application.GetOpenFilename("all,*.*", , "新しいファイルを選択してください")
bfile = Application.GetOpenFilename("all,*.*", , "元のファイルを選択してください")
For Each allbooks In Workbooks
If allbooks.Name = Dir(afile) Then oflag = oflag + 1
If allbooks.Name = Dir(bfile) Then oflag = oflag + 2
Next
If afile = "False" Or bfile = "False" Then Exit Sub
If 1 And oflag = 1 Then
Set aobj = Workbooks(Dir(afile))
Else
Set aobj = Workbooks.Open(Filename:=afile, ReadOnly:=False)
End If
If 2 And oflag = 2 Then
Set bobj = Workbooks(Dir(bfile))
Else
Set bobj = Workbooks.Open(Filename:=bfile, ReadOnly:=False)
End If
aretu = Split(achk, ",")
bretu = Split(bchk, ",")
ThisWorkbook.ActiveSheet.Range("A:A").ClearContents

'Application.ScreenUpdating = False '★★★
For i = 1 To aobj.Sheets.Count
With aobj.Sheets(i)
If schk(.Name, bobj) Then
For Each c1 In aretu
For j = 1 To .Range(c1 & "65536").End(xlUp).Row
hit = 0
For Each c2 In bretu
hit = chk(.Range(c1 & j), bobj.Sheets(.Name).Range(c2 & ":" & c2))
If hit > 0 Then Exit For
Next
If .Range(c1 & j) <> "" And hit = 0 Then
.Range(c1 & j).Interior.Color = RGB(255, 0, 0)
cnt = msg(cnt, "シート=" & .Name & " / 検索セル[値]=" & c1 & j & "[" & .Range(c1 & j) & "]")
End If
Next j
Next
Else
cnt = msg(cnt, aobj.Name & "の" & .Name & "は" & bobj.Name & "に存在しません")
End If
End With
Next i
'Application.ScreenUpdating = True '★★★
End Sub
Function msg(cnt As Integer, word As String)
msg = cnt + 1
ThisWorkbook.ActiveSheet.Range("A" & msg) = word
End Function
Function schk(word As String, target As Object) As Boolean
Dim st As Worksheet
On Error GoTo era
Set st = target.Sheets(word)
schk = True
Exit Function
era:
schk = False
End Function
Function chk(word As String, target As Object) As Integer
On Error GoTo era
chk = WorksheetFunction.Match(word, target, 0)
Exit Function
era:
chk = 0
End Function

■補足■
No4の回答からAブックのセルにセルの背景色を変更する処理が加わっております。
プログラム内部での処理でしたらさほど時間がかからず処理が行えますが、
ユーザーが確認できるようにブックにその都度色を反映させると数が多くなれば処理速度が低下致します。
コード内に「'～～ '★★★」と記載している行が2ヶ所あります。
処理速度を上げる場合は、この２つの行の初めのクォーテーションマーク「'」を削除してください。
（ただし「'★★★」の「'」は削除しないでください）

補足

なぜか先ほどの補足がはいっていなかったようです。

ナンバー4の回答の補足をみて、コードを直してみたら、完璧に赤色になりました！！

1シートづつ、赤色部分を探していくのは少し大変ですが、これはしていかないとダメですね。

何ヶ月もかけて調べていたことが、できるようになって感動しております。

毎日Aのブックを読み取り専用で開いていて、Bブックも開いた状態で仕事の都合上していてるのですが、それは大丈夫でしょうか？

Sub 実行()
Dim afile As String, bfile As String
Dim aobj As Object, bobj As Object
Dim i As Long
Dim cnt As Integer
achk = "B,E"
bchk = "A,B"
afile = Application.GetOpenFilename("all,*.*", , "新しいファイルを選択してください")
bfile = Application.GetOpenFilename("all,*.*", , "元のファイルを選択してください")
If afile = "False" Or bfile = "False" Then Exit Sub
Set aobj = Workbooks.Open(Filename:=afile, ReadOnly:=False)
Set bobj = Workbooks.Open(Filename:=bfile, ReadOnly:=False)
aretu = Split(achk, ",")
bretu = Split(bchk, ",")
ThisWorkbook.ActiveSheet.Range("A:A").ClearContents
For i = 1 To aobj.Sheets.Count
With aobj.Sheets(i)
If schk(.Name, bobj) Then
For Each c1 In aretu
For j = 1 To .Range(c1 & "65536").End(xlUp).Row
hit = 0
For Each c2 In bretu
hit = chk(.Range(c1 & j), bobj.Sheets(.Name).Range(c2 & ":" & c2))
If hit > 0 Then Exit For
Next
If .Range(c1 & j) <> "" And hit = 0 Then
.Range(c1 & j).Interior.Color = RGB(255, 0, 0)
cnt = msg(cnt, "シート=" & .Name & " / 検索セル[値]=" & c1 & j & "[" & .Range(c1 & j) & "]")
End If
Next j
Next
Else
cnt = msg(cnt, aobj.Name & "の" & .Name & "は" & bobj.Name & "に存在しません")
End If
End With
Next i

End Sub
Function msg(cnt As Integer, word As String)
msg = cnt + 1
ThisWorkbook.ActiveSheet.Range("A" & msg) = word
End Function
Function schk(word As String, target As Object) As Boolean
Dim st As Worksheet
On Error GoTo era
Set st = target.Sheets(word)
schk = True
Exit Function
era:
schk = False
End Function
Function chk(word As String, target As Object) As Integer
On Error GoTo era
chk = WorksheetFunction.Match(word, target, 0)
Exit Function
era:
chk = 0
End Function

先ほどのコードでやっているのですが、今もう一度教えて頂いたコードに変えた方が良いですか？

回答No.4

eden3616

>新規ブックにシート=02タイヤ リボン・レター / 検索セル[値]=B1[]
とすごい数が出ているのですが、空白セルとかが感知しているのでしょうか？
それを文字列のみにすることはできますか？
>実際のシートに色を付けるようにできますか？

可能です。以下の状態にする修正を記載します

(1)調べる対象のセルに何も入っていなければスキップする
(2)セルの背景色を付ける

■空白セルの場合は読み飛ばし、背景色をAブックの該当せるに適応する修正
コードの中で26行目から28行目の

If hit = 0 Then
cnt = msg(cnt, "シート=" & .Name & " / 検索セル[値]=" & c1 & j & "[" & .Range(c1 & j) & "]")
End If

のところを

If .Range(c1 & j) <> "" And hit = 0 Then
.Range(c1 & j).Interior.Color = RGB(255, 0, 0)
cnt = msg(cnt, "シート=" & .Name & " / 検索セル[値]=" & c1 & j & "[" & .Range(c1 & j) & "]")
End If

としてください。

◇説明◇――――――――――――――――
RGB(255, 0, 0)の部分で背景色の色を指定しています。
R（赤要素）=255、G（緑要素）=0、B（青要素）＝0で、0～255の値で指定します。
この場合は赤が255（最大）でほかの要素が0（最少）ですので赤色の背景色という意味になります。
http://omotan.com/tools/color-converter.html
上記サイトでRGBの10進数の値と実際の色を確認することができますのでご利用ください。
――――――――――――――――――――

★追加修正★
調べるだけだったので読み取り専用で対象のブックを開き、処理後にマクロで終了させております。
Aブックに色をつけるため、上書き保存する可能性があり、また調べたブックを自動で閉じなくするように修正する必要があります。

■対象のブックを読み取り専用で開かなくする修正
11・12行目の

Set aobj = Workbooks.Open(Filename:=afile, ReadOnly:=True)
Set bobj = Workbooks.Open(Filename:=bfile, ReadOnly:=True)

のところを

Set aobj = Workbooks.Open(Filename:=afile, ReadOnly:=False)
Set bobj = Workbooks.Open(Filename:=bfile, ReadOnly:=False)

としてください

■対象のブックを閉じないようにする修正
36行目の

aobj.Close

を削除してください。
（Bブックも閉じないようにするにはその下の「bobj.Close」も削除してください）

補足

すいません、元となるAブックは、サーバー上にあるブックで、パスワードがついているブックなので、読み取りで常にデスクトップ上に開いている状態なので、元々開いているブックに色をつけると言うことはできますか？本当に何度もすいません。

回答No.3

eden3616

うーん？理解してる内容と要望の内容が異なっていたら申し訳ないです。

(1)Aブックの全てのシートのB列、E列をキーワードにBブックの同一シート名のA列、B列をチェック
(2)Bブックを調べた時に見つからなかった項目をピックアップ（一覧または着色）

ということで作ってみました。
(1)において、Aブックと同じシート名がBブックに存在しなければそのシートでの調査を飛ばしています。
(2)において、着色ではなく一覧をとりました（着色に変更することも可能ですが探すのしんどいのでは？）。
また一覧の表示方法はとりあえず箇条書きにしてますが要望があれば変更可能です。

■マクロの実装方法です

(1)新規ブックを作成
(2)「Alt＋F11」でVBE（visual basic editor）を開く
(3)「挿入」→「標準モジュール」を選択
(4)右上のペインに以下のコードを貼付
(5)VBEを閉じる

＿＿＿＿＿＿＿＿＿＿＿＿
　　　以下はコードです
￣￣￣￣￣￣￣￣￣￣￣￣
Sub 実行()
Dim afile As String, bfile As String
Dim aobj As Object, bobj As Object
Dim i As Long
Dim cnt As Integer
achk = "B,E"
bchk = "A,B"
afile = Application.GetOpenFilename("all,*.*", , "新しいファイルを選択してください")
bfile = Application.GetOpenFilename("all,*.*", , "元のファイルを選択してください")
If afile = "False" Or bfile = "False" Then Exit Sub
Set aobj = Workbooks.Open(Filename:=afile, ReadOnly:=True)
Set bobj = Workbooks.Open(Filename:=bfile, ReadOnly:=True)
aretu = Split(achk, ",")
bretu = Split(bchk, ",")
ThisWorkbook.ActiveSheet.Range("A:A").ClearContents
For i = 1 To aobj.Sheets.Count
With aobj.Sheets(i)
If schk(.Name, bobj) Then
For Each c1 In aretu
For j = 1 To .Range(c1 & "65536").End(xlUp).Row
hit = 0
For Each c2 In bretu
hit = chk(.Range(c1 & j), bobj.Sheets(.Name).Range(c2 & ":" & c2))
If hit > 0 Then Exit For
Next
If hit = 0 Then
cnt = msg(cnt, "シート=" & .Name & " / 検索セル[値]=" & c1 & j & "[" & .Range(c1 & j) & "]")
End If
Next j
Next
Else
cnt = msg(cnt, aobj.Name & "の" & .Name & "は" & bobj.Name & "に存在しません")
End If
End With
Next i
aobj.Close
bobj.Close
End Sub
Function msg(cnt As Integer, word As String)
msg = cnt + 1
ThisWorkbook.ActiveSheet.Range("A" & msg) = word
End Function
Function schk(word As String, target As Object) As Boolean
Dim st As Worksheet
On Error GoTo era
Set st = target.Sheets(word)
schk = True
Exit Function
era:
schk = False
End Function
Function chk(word As String, target As Object) As Integer
On Error GoTo era
chk = WorksheetFunction.Match(word, target, 0)
Exit Function
era:
chk = 0
End Function

■マクロの実行方法です

(1)「表示」タブ→「マクロ」からマクロの保存先「作業中のブック」を選んで上の一覧から「実行」を選択
(2)「実行」をクリック

■マクロの利用方法です

(1)ファイルを開くダイアログが表示されますのでAブック（更新されたブック）を開いてください
(2)ファイルを開くダイアログが表示されますのでBブック（元のブック）を開いてください
(3)実装方法の(1)で作成したブックの現在のシートでA列に結果が出力されます
（添付画像ではわかりやすいように色を着色していますが、実際は着色はありません）

お礼

もし難しいようであれば、Aのシート1-10のB列E列コピー

Aのブックのシート名が同じ場所のBのブック、A列B列に貼り付けとかもできるのでしょうか？

それを条件付き書式で色を付ければ良いのでしょうか？？

エクセルは2010です。

補足

マクロを作って頂き本当に感謝致します。

新規ブックに
シート=02タイヤ リボン・レター / 検索セル[値]=B1[]
とすごい数が出ているのですが、空白セルとかが感知しているのでしょうか？

それを文字列のみにすることはできますか？

実際のシートに色を付けるようにできますか？

回答No.2

eden3616

AのブックとBのブックのシート構成、フォーマット、シート名などは全く同じものですか？

補足

AのブックはA列-IC列まであって、

BのブックはA列、B列しかないです。

シートもAのブックにはないシートもあります。

なので、出来るなら、AのブックのB列とE列だけのデータがほしいので、BのブックにはA列とB列しかありません。。

回答No.1

eden3616

ベースファイルと更新ファイル（元が同じデータ）の場合は私は「エクセル比較」を使っています。
http://www.vector.co.jp/soft/win95/business/se412925.html

比較するシートを指定したり、比較項目を指定（書式や値で比較等）でき
変更箇所を着色したりできます。

補足

こう言ったソフトを数個試したのですが、やはりできませんでした。。