Tipp 0287 Tabellen vergleichen
Autor/Einsender:
Datum:
  Angie
19.11.2002
Entwicklungsumgebung:   Excel 97
Mit diesem Beispiel lässt sich der Inhalt der Zellen (Formatierungen usw. wurden also nicht berücksichtigt) zweier Tabellenblätter vergleichen. Hier wird das Ergebnis des Vergleichs in einer neuen Arbeitsmappe ausgegeben.
 
Public Sub TabellenVergleich(ByVal objWks1 As Worksheet, _
      ByVal objWks2 As Worksheet)

  Dim objWkbDest    As Workbook
  Dim objWksDest    As Worksheet

  Dim optStatusBar  As Boolean

  Dim lngDiffCnt    As Long

  Dim lngRowsCnt1   As Long
  Dim intColsCnt1   As Integer
  Dim lngRowsCnt2   As Long
  Dim intColsCnt2   As Integer

  Dim lngRowsMax    As Long
  Dim intColsMax    As Integer

  Dim strFormula1   As String
  Dim strFormula2   As String

  Dim nRow          As Long
  Dim nCol          As Integer
  Dim lngCounter    As Long

  Dim strTitle      As String

  strTitle = "Vergleich '" & objWks1.Name & "' mit '" & _
        objWks2.Name & "'"

  If Application.WorksheetFunction.CountA(objWks1.Cells) = 0 Then
    MsgBox "Das Tabellenblatt '" & objWks1.Name & _
          "' enthält keine Daten!", vbInformation, strTitle
    Exit Sub
  End If

  If Application.WorksheetFunction.CountA(objWks2.Cells) = 0 Then
    MsgBox "Das Tabellenblatt '" & objWks2.Name & _
          "' enthält keine Daten!", vbInformation, strTitle
    Exit Sub
  End If

  Application.ScreenUpdating = False

  optStatusBar = Application.StatusBar
  Application.StatusBar = True
  Application.StatusBar = "Vergleichstabelle wird erstellt..."

  Set objWkbDest = Application.Workbooks.Add(xlWBATWorksheet)
  Set objWksDest = objWkbDest.Worksheets(1)

  With objWks1.UsedRange
    lngRowsCnt1 = .Rows.Count
    intColsCnt1 = .Columns.Count
  End With

  With objWks2.UsedRange
    lngRowsCnt2 = .Rows.Count
    intColsCnt2 = .Columns.Count
  End With

  If lngRowsCnt1 > lngRowsCnt2 Then
    lngRowsMax = lngRowsCnt1
  Else
    lngRowsMax = lngRowsCnt2
  End If

  If intColsCnt1 > intColsCnt2 Then
    intColsMax = intColsCnt1
  Else
    intColsMax = intColsCnt2
  End If

  lngDiffCnt = 0

  For nCol = 1 To intColsMax
    For nRow = 1 To lngRowsMax
      strFormula1 = vbNullString
      strFormula2 = vbNullString

      strFormula1 = objWks1.Cells(nRow, nCol).FormulaLocal
      strFormula2 = objWks2.Cells(nRow, nCol).FormulaLocal

      If strFormula1 <> strFormula2 Then
        lngDiffCnt = lngDiffCnt + 1
        objWksDest.Cells(nRow, nCol).Formula = _
              "'" & strFormula1 & " <-> " & strFormula2
      End If

      lngCounter = lngCounter + 1
    Next nRow

    Application.StatusBar = "Zellenvergleich... " & _
          Format(lngCounter / (intColsMax * lngRowsMax), "0 %")
  Next nCol

  If lngDiffCnt = 0 Then
    objWkbDest.Close SaveChanges:=False
  Else
    With objWksDest
      .Name = "Vergleichsergebnis"
      With .Range(.Cells(1, 1), .Cells(lngRowsMax, intColsMax))
        .Interior.ColorIndex = 36
        .Columns.AutoFit
      End With
    End With
    Application.ActiveWindow.Zoom = 75
  End If

  Set objWksDest = Nothing
  Set objWkbDest = Nothing

  Application.StatusBar = vbNullString
  Application.StatusBar = optStatusBar

  Application.ScreenUpdating = True

  MsgBox "Der Inhalt von  " & lngDiffCnt & _
        " Zellen weichen voneinander ab !", _
        vbInformation, strTitle
End Sub
 
Weitere Links zum Thema
Doppelte Datensätze ermitteln (DAO)
Doppelte Datensätze löschen
Doppelte Datensätze löschen (DAO)
Hinweis
Die im Download befindliche *.bas-Datei kann in Excel im VB-Editor importiert werden.

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
Excel-Version
95
97
2000
2002 (XP)
2003
2007
2010


Download  (2,5 kB) Downloads bisher: [ 5149 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Samstag, 6. August 2011