EXCEL VBA シート比較し〇×判定

度々質問すいません。

下記コードでシート名一覧をだし、ダブルクリックしたら該当シートをコピーし、ダイアログで選択したブックに張り付けています。
シートを張り付けるときにシートを比較し、
新しいシートを作り、合っているものは〇、間違っているものは×　を表示したいです。
また、一番右に×の数をカウントしたいです。

例　画像のシート２を貼り付けたら、シート３を作り〇×判定し、右に×の数カウントするようなもの


文章見にくくてすみません。
分かる方いましたらご教授ください。
よろしくお願い致します。


下記コードです。

Sub 検索()
Dim fn(10000) 'フォルダ内ファイル名
Dim sn(10000, 2) 'フォルダ内エクセルファイル名、シート名
Dim i As Long, j As Long, k As Long, x As Long
Dim myPath As String 'フォルダパス
Dim ext As String '拡張子検索変数


'フォルダの選択
With Application.FileDialog(msoFileDialogFolderPicker) 'ダイアログ表示
.Title = "フォルダを選択"
.AllowMultiSelect = False
If .Show = -1 Then
myPath = .SelectedItems(1) 'パス取得
Else
Exit Sub
End If
End With

Application.ScreenUpdating = False '画面更新非表示

'ファイル名の取得
fn(1) = Dir(myPath & "\", vbDirectory)
i = 1
Do
i = i + 1
fn(i) = Dir

Loop Until fn(i) = ""


'シート名の取得
x = 0
For j = 1 To i - 1
ext = Mid(fn(j), InStrRev(fn(j), ".") + 1, 3) '拡張子取得
'エクセルファイルの時実行
If ext = "xls" Then
Workbooks.Open Filename:=myPath & "\" & fn(j)
For k = 1 To Sheets.Count
sn(x, 1) = fn(j) 'エクセルファイル名取得
sn(x, 2) = Sheets(k).Name 'シート名取得

x = x + 1
Next k
ActiveWorkbook.Close
End If
Next j




'シート名一覧の作成
Columns("A:B").Select
Selection.ClearContents
Cells(2, 1) = "作業フォルダ"
Cells(3, 1) = myPath
Cells(4, 1) = "ファイル名"
Cells(4, 2) = "シート名"
x = 0
Do
Cells(x + 5, 1) = sn(x, 1)
Cells(x + 5, 2) = sn(x, 2)
x = x + 1
Loop Until sn(x, 1) = ""



Range("A1").Select

Application.ScreenUpdating = True '画面更新表示


MsgBox "完了しました"

End Sub

'シート名ダブルクリックすると実行
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim fn As String, bk As String, pth As String
Dim ptBk As Workbook, ptBk_pth As String

If Intersect(Target, Range("B5", Cells(Rows.Count, "B").End(xlUp))) Is Nothing Then Exit Sub
Cancel = True
pth = Range("A3").Value
bk = Target.Offset(, -1).Value
fn = Target.Value

ptBk_pth = Application.GetOpenFilename("Excelブック,*.xls?") 'コピー先のブック選択

If ptBk_pth = "False" Then Exit Sub 'キャンセル時終了

Application.ScreenUpdating = False '画面更新非表示

Set ptBk = Workbooks.Open(ptBk_pth)
With Workbooks.Open(pth & "\" & bk)
Application.EnableEvents = False
.Sheets(fn).Copy Before:=ptBk.Sheets(1)
Application.EnableEvents = True

.Close savechanges:=False 'コピー元は保存せず閉じる
End With
ptBk.Close savechanges:=True 'コピー先は保存し閉じる
Application.ScreenUpdating = True '画面更新表示

End Sub

No.1 ベストアンサー 回答者： mygoonickname 回答日時： 2021/11/20 09:54

おはようございます。

空のシートを作った後に、Excelの関数を入れた方が簡単な様な気がします。
例えば、セル　A5:B5　に、=IF(Sheet○!A5=Sheet△!A5,"○","×")
を入れて、データの末尾までコピーすれば、○又は、×が表示されるかと。
セル　C5に、=COUNTIF(A5:B5,"×")　を入れて、データの末尾まで
コピーすれば、×の個数をカウントできると思います。

マクロの記録で行えば、式などもすぐにできるかと。
式が入っているのが嫌でしたら、計算式をコピーして、値として貼り付けを
すれば、値になりますので。　これも、マクロを記録すれば分かるかと。