Option Explicit

    Dim sDateiName1 As String
    Dim sDateiName2 As String
    Dim bDateiNum1 As Byte
    Dim bDateiNum2 As Byte

Private Sub CommandButton1_Click()

    Call GetOpen_FileName
    'Call Vergleich_Arbeitsmappen
    
End Sub

Private Sub GetOpen_FileName()
    
    Dim sPfadName1 As Variant
    Dim sPfadName2 As Variant
    Dim i As Integer
    Dim n As Long
    Dim x As Long
    Dim lName1 As Long
    Dim lName2 As Long
    Dim iWorkbook As Integer
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    
    MsgBox "Wählen Sie die beiden Exceltabellen die Verglichen werden sollen.", vbQuestion & vbOKOnly, "Info"
    ChDrive "T"
    ChDir "T:\delme\Ruckes\Vergleich"
          
    sPfadName1 = Application.GetOpenFilename("Excel-Dateien (*.xl??), *.xl??", Title:="Bitte Exceldatei auswählen")
    'Extraktion des Mappennamen
    If Not sPfadName1 = False Then
      Workbooks.Open sPfadName1
      sPfadName1 = Mid$(sPfadName1, InStrRev(sPfadName1, "\") + 1)
      x = (InStrRev(CStr(sPfadName1), ".") - 1)
      lName1 = Len(sPfadName1) - (Len(sPfadName1) - x)
      sDateiName1 = Left(sPfadName1, lName1)
      'MsgBox (sDateiName1)
    Else
      Exit Sub
    End If
    
    sPfadName2 = Application.GetOpenFilename("Excel-Dateien (*.xl??), *.xl??", Title:="Bitte die Vergleichsdatei auswählen")
    
    If Not sPfadName2 = False Then
      Workbooks.Open sPfadName2
      sPfadName2 = Mid$(sPfadName2, InStrRev(sPfadName2, "\") + 1)
      i = (InStrRev(CStr(sPfadName2), ".") - 1)
      lName2 = Len(sPfadName2) - (Len(sPfadName2) - i)
      sDateiName2 = Left(sPfadName2, lName2)
      'MsgBox (sDateiName2)
    Else
      Exit Sub
    End If
    
    Set wb1 = Workbooks(sDateiName1)
    Set wb2 = Workbooks(sDateiName2)
    
    For iWorkbook = 1 To Workbooks.Count
      If Workbooks(iWorkbook).Name = wb1.Name Then
        bDateiNum1 = iWorkbook
      End If
      
      If Workbooks(iWorkbook).Name = wb2.Name Then
        bDateiNum2 = iWorkbook
      End If
    Next iWorkbook
    
End Sub

Private Sub Vergleich_Arbeitsmappen()

    'Vergleich von Mappe X mit Mappe Y
    Dim intWB As Integer, intWS As Integer
    Dim objDic As Object
    Dim regObj As Range
    
    Set objDic = CreateObject("scripting.dictionary")

    'Vergleich Anzahl der Tabellenblätter
    If Workbooks(sDateiName1).Worksheets.Count <> Workbooks(sDateiName2).Worksheets.Count Then
      MsgBox "Die Anzahl der Tabellenblätter ist unterschiedlich!"
    End If

    'Vergleich der benutzen Zellen
    For intWS = 1 To Workbooks(sDateiName1).Worksheets.Count
      If Workbooks(sDateiName1).Worksheets(intWS).UsedRange.Cells.Count <> Workbooks(sDateiName2).Worksheets(intWS).UsedRange.Cells.Count Then
        MsgBox "Die Anzahl der benutzen Zellen in Blatt " & intWS & " " & "ist unterschiedlich!"
      End If

    'Vergleich der Zellinhalte
      For Each regObj In Workbooks(sDateiName1).Worksheets(intWS).UsedRange
        If Not regObj = "" Then
          If regObj.Value <> Workbooks(sDateiName2).Worksheets(intWS).Range(regObj.Address).Value Then
            For intWB = bDateiNum1 To bDateiNum2
              Workbooks(intWB).Worksheets(intWS).Activate
              ActiveSheet.Range(regObj.Address).Interior.ColorIndex = 3
            Next
          Else
            For intWB = bDateiNum1 To bDateiNum2
              Workbooks(intWB).Worksheets(intWS).Activate
              ActiveSheet.Range(regObj.Address).Interior.ColorIndex = 4
            Next
          End If
        End If
      Next
    Next
End Sub