エクセルのファイル内データ比較

質問

データがエクセルファイルなのでここで質問いたします．
エクセルファイルが３００個ぐらいあります．
この中で基本になるファイルは５０個ぐらいあります．
その５０個のファイルの１つと残り２５０個ぐらいのファイル内データを比較できる方法はないでしょうか？
当然一気に比較する方法ではなくてもかまいません．
現在１つ１つ開いて見て比較する途方もない作業で死にそうです．
ファイル内データはマクロもなければ計算式すらありません．
数字データがA1～A90，B1～B90まで入っています．
データ数は全ファイル共通となっています．
どなたか良い知恵を授けてください．お願いします．

回答No.3

nishi6

前の回答と同様の前提です。
横に５０余りのBook、縦に２５０余りのBookのSheet1のセル内容を取り込みます。AB列それぞれで比較しています。
各シートの差の絶対値を計算・表示し、シート単位のＡ・Ｂ列の絶対値計を計算し、ゼロでなければ青く色が付きます。

実際、３００余りのBookでどの位時間がかかるか不明です。３００Bookを一括処理が可能かも不明です。
基本３Book、比較対象６Bookで数秒です。(こちらはPentium120、32MB (;o;)とかなり遅い！ )
数Bookでテストして見て下さい。けっこうおもしろい問題でした。

標準モジュールに貼り付けます。
Public Sub SheetsHikakuCell()
　Dim MainFolder As String, MainExcel As String, MainBookNum As Integer ' 50シートのフォルダ,ファイル名,数
　Dim Sub_Folder As String, Sub_Excel As String, Sub_BookNum As Integer '250シートのフォルダ,ファイル名,数 '

　Dim myBookName As String '集計用ブック名
　　myBookName = ThisWorkbook.Name
　Dim sht1 As Worksheet '集計用シート
　Dim rg As Range '集計用シートのA1
　Set sht1 = Worksheets("Sheet1")
　Set rg = sht1.Range("A1")

　MainFolder = "C:\benkyo\Main" '<=== 変更して下さい
　Sub_Folder = "C:\benkyo\Sub" '<=== 変更して下さい

　Application.ScreenUpdating = False

　' 50シートの方を読む。
　MainExcel = Dir(MainFolder & "\" & "*.xls")
　While MainExcel <> ""
　　Workbooks.Open MainFolder & "\" & MainExcel
　　　MainBookNum = MainBookNum + 1

　　　Workbooks(myBookName).Activate
　　　　With Worksheets("Sheet1").Range("A1")
　　　　　.Offset(0, MainBookNum * 4) = MainExcel
　　　　　Workbooks(MainExcel).Worksheets("Sheet1").Range("A1:B90").Copy _
　　　　　　　Destination:=.Offset(0, MainBookNum * 4 + 1)
　　　　End With
　　　　Workbooks(MainExcel).Close

　　MainExcel = Dir
　Wend

　'250シートの方を読む。
　Sub_Excel = Dir(Sub_Folder & "\" & "*.xls")
　While Sub_Excel <> ""
　　Workbooks.Open Sub_Folder & "\" & Sub_Excel
　　　Sub_BookNum = Sub_BookNum + 1

　　　Workbooks(myBookName).Activate
　　　　With Worksheets("Sheet1").Range("A1")
　　　　　.Offset(Sub_BookNum * 100, 0) = Sub_Excel
　　　　　Workbooks(Sub_Excel).Worksheets("Sheet1").Range("A1:B90").Copy _
　　　　　　　Destination:=.Offset(Sub_BookNum * 100, 1)
　　　　End With
　　　　Workbooks(Sub_Excel).Saved = True
　　　　Workbooks(Sub_Excel).Close

　　Sub_Excel = Dir
　Wend

　Dim rwCot As Integer
　With Worksheets("Sheet1").Range("A1")
　　'ファイル名のコピー
　　.Offset(100, 4).Formula = "=E1"
　　'A列の差額計算式
　　For rwCot = 1 To 90
　　　.Offset(99 + rwCot, 5).Formula = "=Abs(F$" & rwCot & "-$B" & (100 + rwCot) & ")"
　　Next
　　'B列の差額計算式
　　For rwCot = 1 To 90
　　　.Offset(99 + rwCot, 6).Formula = "=Abs(G$" & rwCot & "-$C" & (100 + rwCot) & ")"
　　Next
　　'A列差の絶対値計
　　.Offset(102, 4) = "A列差の絶対値計"
　　.Offset(103, 4).Formula = "=Sum(F101:F190)"
　　.Offset(103, 4).FormatConditions.Delete '条件付き書式を設定
　　.Offset(103, 4).FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="0"
　　.Offset(103, 4).FormatConditions(1).Interior.ColorIndex = 8
　　'B列差の絶対値計
　　.Offset(105, 4) = "B列差の絶対値計"
　　.Offset(106, 4).Formula = "=Sum(G101:G190)"
　　.Offset(106, 4).FormatConditions.Delete '条件付き書式を設定
　　.Offset(106, 4).FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="0"
　　.Offset(106, 4).FormatConditions(1).Interior.ColorIndex = 8
　End With

　'差額の式をコピー
　Dim mn, sb As Integer 'Bookカウンタ
　Range("E101:G190").Copy
　For mn = 1 To MainBookNum
　　For sb = 1 To Sub_BookNum
　　　Range("E101").Offset((sb - 1) * 100, (mn - 1) * 4).Select
　　　ActiveSheet.Paste
　　Next
　Next

　Application.ScreenUpdating = True

End Sub

お礼

ありがとうございます．
プログラムも書いて頂き
大変恐縮です．
うまく行きそうです．