GDIplusCODE

'全Sheet内で重複チェック
'各シートB21～B列最終行の値でチェック
'重複したデータ全体を新規シートにコピー
'元のシート名とアドレスを転記先のA列に表示
Sub test2()
  Dim I As Long, lastRow As Long
  Dim myDic As Object
  Dim tempCollection As Collection
  Dim myKey As Variant, myKeys As Variant
  Dim destRange As Range, myRange As Range
  Dim sh As Worksheet, newSh As Worksheet
  
  Const startRow As Long = 21
  Const checkColumn As Long = 2
  
  Application.ScreenUpdating = False
  Set myDic = CreateObject("Scripting.Dictionary")
  'DictionaryにRangeのCollectionを収納。重複した値のセルはCollectionに追加。
  For Each sh In ThisWorkbook.Worksheets
    With sh
      lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
      For I = startRow To lastRow
        If Not myDic.exists(CStr(.Cells(I, checkColumn).Value)) Then
          Set tempCollection = New Collection
          tempCollection.Add .Cells(I, checkColumn)
          myDic.Add CStr(.Cells(I, checkColumn).Value), tempCollection
          'ここで消してしまってもDictionaryに収納したCollectionは保持される
          Set tempCollection = Nothing
        Else
          myDic.Item(CStr(.Cells(I, checkColumn).Value)).Add .Cells(I, checkColumn)
        End If
      Next I
    End With
  Next sh
  With ThisWorkbook
    Set newSh = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
  End With
  Set destRange = newSh.Range("B1")
  myKeys = myDic.keys
  For Each myKey In myKeys
    'collectionのセル数が2個以上であれば
    If myDic.Item(myKey).Count > 1 Then
      For I = 1 To myDic.Item(myKey).Count
        Set myRange = myDic.Item(myKey).Item(I)
        With myRange
          'A列に元データのあるシート名と番地を表示
          destRange.Offset(0, -1).Value = .Parent.Name & "!" & .Address
          Range(.Offset(0, -1), .EntireRow.Cells(newSh.Columns.Count).End(xlToLeft)).Copy destRange
          Set destRange = destRange.Offset(1, 0)
        End With
      Next I
    End If
  Next myKey
  Set myDic = Nothing
  Application.ScreenUpdating = True
End Sub
Bookの全シート間で重複チェック
