Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1160to1164
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Identische und unterschiedliche Einträge suchen

Identische und unterschiedliche Einträge suchen
Stefan
Hallo,
nachdem mir hier schon einige mal sehr gut geholfen wurde habe ich nochmal eine Frage. Folgendes
Probelem:
Ich habe 2 Arbeitsmappen mit verschieden vielen Datensätzen jeweils in Tabelle1. Die Einträge in Spalte A
können in beiden Arbeitsmappen vorkommen, müssen dies aber nicht, d.h. es kommen in Spalte A der beiden Mappen sowohl identische wie auch unterschiedliche Einträge vor. Ich möchte nun ermitteln welche
Einträge in Spalte A beier Tabellen vorkommen und welche nur in einer von beiden? Wie kann ich das realisieren? Kann mir jemand weiterhelfen?
Viele Grüße
Stefan

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Identische und unterschiedliche Einträge suchen
10.06.2010 20:50:18
Josef

Hallo Stefan,
wie und wo sollen die gleiche/unterschiedlichen Datensätze gekennzeichnet bzw. aufgelistet werden?
In einer der beiden Tabellen, in beiden oder in einer neuen Tabelle?

Gruß Sepp

AW: Identische und unterschiedliche Einträge suchen
10.06.2010 22:12:47
Stefan
Hallo Sepp,
sorry, hab ich vergessen mitzuteilen. Am besten wäre in einer neuen Tabelle, wenn das nicht zu kompliziert ist.
Stefan
Anzeige
AW: Identische und unterschiedliche Einträge suchen
10.06.2010 23:43:01
Josef

Hallo Stefan,
die Tabelle wird in der Datei die den Code enthält angelegt.
Füge den Code in ein allgemeines Modul ein.

' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub compareSheets()
  Dim objWB As Workbook
  Dim vntSrc1 As Variant, vntSrc2 As Variant
  Dim vntInBoth() As Variant, vntInFirstOnly() As Variant, vntInSecondOnly() As Variant
  Dim lngIndex As Long, lngCBoth As Long, lngCFirst As Long, lngCSecond As Long
  Dim vntRet As Variant, blnWasOpen As Boolean
  Dim strFile1 As String, strFile2 As String
  
  strFile1 = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
    "*.xls; *.xlsx; *.xlsm", Title:="Bitte erste Datei wählen")
  
  If strFile1 = CStr(False) Then Exit Sub
  
  strFile2 = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
    "*.xls; *.xlsx; *.xlsm", Title:="Bitte zweite Datei wählen")
  
  If strFile2 = CStr(False) Then Exit Sub
  
  On Error GoTo Errexit
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With
  
  For Each objWB In Workbooks
    If objWB.FullName = strFile1 Then
      blnWasOpen = True
      Exit For
    End If
  Next
  If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile1)
  With objWB.Sheets("Tabelle1")
    vntSrc1 = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
  End With
  If Not blnWasOpen Then objWB.Close False
  Set objWB = Nothing
  blnWasOpen = False
  For Each objWB In Workbooks
    If objWB.FullName = strFile2 Then
      blnWasOpen = True
      Exit For
    End If
  Next
  If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile2)
  With objWB.Sheets("Tabelle1")
    vntSrc2 = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
  End With
  If Not blnWasOpen Then objWB.Close False
  
  Redim vntInBoth(0)
  vntInBoth(0) = "In beiden Dateien"
  lngCBoth = 1
  
  Redim vntInFirstOnly(0)
  vntInFirstOnly(0) = "Nur in Datei " & strFile1
  lngCFirst = 1
  
  Redim vntInSecondOnly(0)
  vntInSecondOnly(0) = "Nur in Datei " & strFile2
  lngCSecond = 1
  
  For lngIndex = 1 To UBound(vntSrc1, 1)
    vntRet = Application.Match(vntSrc1(lngIndex, 1), vntSrc2, 0)
    If IsNumeric(vntRet) Then
      Redim Preserve vntInBoth(lngCBoth)
      vntInBoth(lngCBoth) = vntSrc1(lngIndex, 1)
      lngCBoth = lngCBoth + 1
    Else
      Redim Preserve vntInFirstOnly(lngCFirst)
      vntInFirstOnly(lngCFirst) = vntSrc1(lngIndex, 1)
      lngCFirst = lngCFirst + 1
    End If
  Next
  
  For lngIndex = 1 To UBound(vntSrc2, 1)
    vntRet = Application.Match(vntSrc2(lngIndex, 1), vntSrc1, 0)
    If Not IsNumeric(vntRet) Then
      Redim Preserve vntInSecondOnly(lngCSecond)
      vntInSecondOnly(lngCSecond) = vntSrc2(lngIndex, 1)
      lngCSecond = lngCSecond + 1
    End If
  Next
  
  ThisWorkbook.Worksheets.Add after:=ActiveSheet
  
  With ActiveSheet
    .Name = "Vergleich_" & Format(Now, "yyyymmdd-hhMMss")
    .Range("A1").Resize(UBound(vntInBoth) + 1, 1) = Application.Transpose(vntInBoth)
    .Range("B1").Resize(UBound(vntInFirstOnly) + 1, 1) = Application.Transpose(vntInFirstOnly)
    .Range("C1").Resize(UBound(vntInSecondOnly) + 1, 1) = Application.Transpose(vntInSecondOnly)
    .Rows(1).Font.Bold = True
    .Columns.AutoFit
  End With
  
  Errexit:
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
  Set objWB = Nothing
End Sub

Gruß Sepp

Anzeige
AW: Identische und unterschiedliche Einträge suchen
11.06.2010 05:31:54
Stefan
Hallo Sepp,
oha, das war wohl komplizierter als ich dachte. Ich probiere es aus und gebe dir dann Nachricht. Auf jeden Fall Herlichen Dank.
Viele Grüße
Stefan

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige