Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1304to1308
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

Doppelte Einträge in mehreren Dateien finden

Doppelte Einträge in mehreren Dateien finden
04.04.2013 09:28:28
Toumas
Hallo zusammen,
ich habe mal wieder eine nette Aufgabe bekommen, ich soll in mehreren Dateien (die Anzahl ist von Monat zu Monat unterschiedlich) die doppelten Daten rausfiltern.
Der "Vorteil" ist, es handelt sich um reine Aktenzeichen die aus Nummern und/oder Buchstaben bestehen können und nicht aus Namen, Adressen oder dergleichen, die man falsch schreiben könnte.
Den Vergleich der doppelten Werte innerhalb der Tabelle mache ich, indem ich erst die Tabelle aufsteigend sortieren lasse und dann mit =WENN(A1=A2;1;0)
mir entsprechend kennzeichnen lasse, welcher Wert doppelt ist. Die nicht doppelten Werte kopiere ich in ein neues Tabellenblatt).
Meine Idee war bisher, ich nehme nun die Werte aus Datei 1, vergleiche diese mit den Werten aus Datei 2 und kopiere die daraus resultierenden Daten (die nicht doppelt sind) in eine dritte Datei.
Diese Ergebnisdatei nehme ich dann als neue Basis um sie mit der Datei 3 zu vergleichen. Die daraus resultierende Ergebnisdatei vergleiche ich mit Datei 4 usw. usw. usw. (ich hoffe, der Gedanke ist halbwegs nachvollziehbar)
Bei drei oder vier Dateien mag dies zwar umständlich aber noch halbwegs praktikabel sein... (auch wenn jede Datei zwischen 1000 - 4000 Einträge in der entsprechenden Tabelle enthält).
Aber bei mehr Dateien (und es sind im Schnitt 20 - 30 je Monat) weiß ich, dass dies so eigentlich nicht ausführbar ist.
Gibt es andere Lösungsansätze, Ideen oder dergleichen, die mich da etwas weiter bringen.
Access als Zwischenlösung wurde leider von meinem Chef angelehnt.
Vielen Dank schon mal im Voraus
Viele Grüße
Toumas

20
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 09:54:31
Tino
Hallo,
man könnte doch auch alle Daten zusammenkopieren und mittels Spezialfilter die doppelten rausfiltern?
Gruß Tino

AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 10:21:21
Toumas
Hallo Tino,
das Problem ist, dass ich nicht unbedingt 30 Dateien einzeln, öffnen, kopieren, filtern und dann neu speichern möchte.
Die bisherige Auswertung (oben beschrieben), der doppelten Dateien habe ich ein mal vorgeschrieben und in die dafür vorgesehen Zellen werden die entsprechenden Werte immer von einem anderen Bearbeiter reinkopiert. Diese ist aber nur für die jeweilige Datei gültig. Einen Vergleich der einzelnen Dateien untereinander fehlt mir noch... Da hatte ich bisher nur diesen "Gedanken" wie oben beschrieben.
Ich suche (wahrscheinlich eine utopische Vorstellung) nach einer Lösung, per Makro oder dergleichen, die mir per Button das ganze
- Sortiert
- Vergleicht
- die nicht doppelten Werte in eine neue Datei speichert
Den Spezialfilter habe ich schon versucht, nur müsste ich diesen jedes mal aufs Neue anwenden, da die Daten sich jeweils ändern können.... Daher fällt er leider aus.
Viele Grüße
Toumas

Anzeige
AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 10:26:33
Klaus
Hi,
In Pseudocode also so:
- öffne 30 Dateien(1-30)
- kopiere Daten aus 30 Dateien in neue Datei(31)
- schließe Dateien(1-30)
- Spezialfilter auf Datei(31), doppelte entfernen
die alten Dateien werden dabei NICHT geändert, richtig?
Sin die Dateinamen jedesmal gleich, oder variabel? Wenn die jedes mal gleich sind, hab ich hier ein Makro rumliegen das fast genau das macht. Bei positiver Rückmeldung lade ich mal ein Beispiel hoch.
Grüße,
Klaus M.vdT.

AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 10:37:06
Toumas
Hallo Klaus,
leider sind die Dateinamen immer anders, diese setzten sich aus einem fixen Teil, dem Datum und der Uhrzeit des jeweiligen Scanvorganges zusammen.
Also : xxxxxxx.Datum.Uhrzeit.xls
Aber ich bin für jeden Tipp, jedes Makro dankbar
Viele Grüße
Thomas

Anzeige
Anregung:
04.04.2013 11:27:20
Klaus
Hi,
folgendes ist vielleicht ein Ansatz für dich, aber sicher nicht die endgültige Lösung.
hier mal ein leicht modifiziertes "Standardfile" von mir. Ein paar Sachen zuviel für deine Anwendung, die kannst du einfach ignorieren.
https://www.herber.de/bbs/user/84703.xlsm
Im sheet "Update" trägst du in die gelben Zellen in D den Pfad, in F die Dateinamen (mit korrekter Endung *.xls, *.xlsm und so weiter!) und in H das Tab, aus dem die Daten geholt werden sollen, ein. Das Beispiel ist für drei Dateien, kannst du aber einfach nach unten fortsetzen bis der Artzt kommt.
In Spalte "J" muss immer das Sheet "sammeln" angebeben sein! Das habe ich in den nötigen Änderungen hart codiert.
Der Button "Dateiinhalte holen" öffnet dir alle gelisteten Dateien, und kopiert die Inhalte untereinander ins sheet "Sammeln" (die Inhalte = die UsedRange aus dem angegebenen Blatt der Datei!).
Der Button "Duplikate löschen" führt im Blatt "Sammeln" folgende Aktion aus:
Spalte A:C, für Dublikate in Spalte A die gesamte Zeile löschen.
Das musst du dir noch anpassen.
Eine Lösung, wie du die variablen Dateinamen listest, habe ich nicht. Vielleicht kann da Rudi helfen, sein Vorschlag ging ja in diese Richtung (alle Dateien im Ordner X). Ich traue mir aber nicht zu, Rudis Code anzupassen.
Grüße,
Klaus M.vdT.

Anzeige
AW: Anregung:
04.04.2013 11:59:25
Toumas
Hallo Klaus,
danke dir für die Antwort,
dies kann ich leider erst heute Abend von meinem privaten Rechner testen, da wir auf Arbeit keinerlei
Dateien runterladen dürfen.
Melde mich dann wieder.
Viele Grüße

AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 11:52:45
Tino
Hallo,
ich dachte bei VBA nein, wäre eine VBA Version nicht gewollt.
Hier mal eine Variante.
Code Sucht alle Exceldateien in den angegeben Ordner und
sammelt die Daten aus der 1. Tabelle Spalte A ohne doppelte und
gibt diese in der Datei aus wo der Code steht.
Bei einer großen Anzahl Dateien kann der Code mehr oder weniger lang dauern,
dies kannst Du in der Statusleiste verfolgen.
Sub Start()
Dim ArData, ArFile(), n&, nn&
Dim oDic As Object, oApp As Excel.Application
Dim sPath$, tmpFileName$

sPath = "G:\1 Forum\Test2\Test3" 'Pfad anpassen 

sPath = IIf(Right$(sPath, 1) <> "\", sPath & "\", sPath)
tmpFileName = Dir(sPath & "*.xls?", vbNormal)
Do While tmpFileName <> ""
    Redim Preserve ArFile(n)
    ArFile(n) = sPath & tmpFileName
    n = n + 1
    tmpFileName = Dir()
Loop
If n < 1 Then Exit Sub 'keine Datei gefunden 

Set oApp = New Excel.Application

Set oDic = CreateObject("Scripting.Dictionary")
With oApp
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    
    For n = Lbound(ArFile) To Ubound(ArFile)
        Application.StatusBar = "Lese Datei " & n + 1 & " von " & Ubound(ArFile) + 1
        With .Workbooks.Open(Filename:=ArFile(n), ReadOnly:=True)
            With .Sheets(1) 'evtl. anpassen 
                nn = .Cells(.Rows.Count, 1).End(xlUp).Row
                If nn > 1 Then
                    ArData = .Range("A2", .Cells(nn, 1)).Resize(, 2)
                End If
            End With
            .Close False
        End With
        If IsArray(ArData) Then
            For nn = 1 To Ubound(ArData)
                oDic(ArData(nn, 1)) = 0
            Next nn
        End If
        ArData = Empty
    Next n

    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Quit
End With
Set oApp = Nothing
Application.StatusBar = False
If oDic.Count > 0 Then
    ArData = TransposeData(oDic.keys)
    With ThisWorkbook.Sheets("Tabelle1") 'evtl. anpassen 
        .Range("A2", .Cells(.Rows.Count, 1)).ClearContents 'alte Daten löschen 
        .Range("A2").Resize(Ubound(ArData), Ubound(ArData, 2)) = ArData
    End With
End If
MsgBox "fertig"
Set oDic = Nothing
End Sub

Function TransposeData(ArValues)
Dim n&, NewAr()
Redim Preserve NewAr(1 To Ubound(ArValues) + 1, 1 To 1)
For n = Lbound(ArValues) To Ubound(ArValues)
    NewAr(n + 1, 1) = ArValues(n)
Next n
TransposeData = NewAr
End Function
Gruß Tino

Anzeige
AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 12:00:53
Toumas
ach so...
ich dachte immer, das mit dem VBA spiegelt meine Kenntnisse darin wieder... und die sind mehr als bescheiden...
Danke Tino,
ich werde es nachher gleich mal testen..... leider haben wir erst mal Besprechnung.
Viele Grüße

Level
04.04.2013 12:09:18
Tino
Hallo,
naja ist eben immer so eine Sache mit der Angabe eines Levels.
Der eine sieht es so der andere so.
Wenn ich VBA-Nein lese, gehe ich davon aus das er keinerlei VBA Kenntnisse hat und somit
mit einem Code überhaupt nichts anfangen kann.
Gruß Tino

AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 14:26:16
Toumas
Hallo Tino,
erst mal zum Level :
Ich bin grundsätzlich VBA nicht abgeneigt, aber habe einfach (noch) zu wenig Ahnung um es selbstständig umzusetzen.... Aber ich wurstel mich durch
Zu deinem Makro...
Funktioniert super, so wie ich es (fast) haben wollte...
kann man die Kopierfunktion noch so "erweitern"
Dass
1.) die Doppelten in ein extra Tabellenblatt kopiert werden
2.) nicht nur die Spalte A, sondern dann die ganze Zeile kopiert wird
Aber jetzt schon mal ein riesiges Dankeschön....
Viele Grüße
Toumas

Anzeige
AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 15:05:08
Toumas
Nachtrag
Mein Chef hat "tolle" Ideen...
kann man, neben den anderen beiden Dingern
bei den kopierten doppelten noch dahinter irgendwie zählen lassen, wie oft die in den Dateien vorgekommen sind ?
d.H.
die Doppelten werden in ein extra Tabellenblatt kopiert und in eine leere Spalte steht dahinter wie oft die in den Tabellen vorgekommen sind
Alternativ
bei den durch das Makro eingefügten, die Zählung in jeweils einer leere Zelle , wie oft diese vorgekommen ist... dann müsste man das Kopieren der Doppelten in ein extra Tabellenblatt nicht mehr machen...
Sorry für die Extrawürste.....
Viele Grüße
Toumas

Anzeige
AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 15:10:30
Toumas
Nachtrag 2
beim kopieren der gesamten Zeile ist mir aufgefallen, dass die relevanten Daten "nur"
in A - S stehen.... "mehr" müsste man dann nicht kopieren.... (ich weiß nicht, ob das einfacher nachher für VBA ist)
so und nu ist es mit den Extrawünschen hoffentlich gut... ;-)
Viele Grüße

AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 23:15:55
Tino
Hallo,
hoffe alle Wünsche zu erfüllen.
Sub Start()
Dim ArData, ArFile(), ArAusgabe(), n&, nn&, nnn&, nCount&
Dim oDic As Object, oApp As Excel.Application
Dim sPath$, tmpFileName$

sPath = "G:\1 Forum\Test2\Test3" 'Pfad anpassen ********** 

sPath = IIf(Right$(sPath, 1) <> "\", sPath & "\", sPath)
tmpFileName = Dir(sPath & "*.xls?", vbNormal)
Do While tmpFileName <> ""
    Redim Preserve ArFile(n)
    ArFile(n) = sPath & tmpFileName
    n = n + 1
    tmpFileName = Dir()
Loop
If n < 1 Then Exit Sub 'keine Datei gefunden ************* 

Set oApp = New Excel.Application

Set oDic = CreateObject("Scripting.Dictionary")
With oApp
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    
    For n = Lbound(ArFile) To Ubound(ArFile)
        Application.StatusBar = "Lese Datei " & n + 1 & " von " & Ubound(ArFile) + 1
        With .Workbooks.Open(Filename:=ArFile(n), ReadOnly:=True)
            With .Sheets(1) 'evtl. anpassen 
                nn = .Cells(.Rows.Count, 1).End(xlUp).Row
                If nn > 1 Then
                    ArData = .Range("A2", .Cells(nn, 1)).Resize(, 19) 'bis Spalte S 
                End If
            End With
            .Close False
        End With
        If IsArray(ArData) Then
            For nn = 1 To Ubound(ArData)
                If Not oDic.exists(ArData(nn, 1)) Then
                    nCount = nCount + 1
                    Redim Preserve ArAusgabe(1 To 20, 1 To nCount)
                    For nnn = 2 To Ubound(ArData, 2)
                        ArAusgabe(nnn + 1, nCount) = ArData(nn, nnn)
                    Next nnn
                    ArAusgabe(1, nCount) = ArData(nn, 1)
                End If
                oDic(ArData(nn, 1)) = oDic(ArData(nn, 1)) + 1
            Next nn
            ArData = Empty
        End If
    Next n

    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Quit
End With
Set oApp = Nothing
Application.StatusBar = False
If oDic.Count > 0 Then
    ArAusgabe = TransposeData(ArAusgabe, oDic)
    With ThisWorkbook.Sheets.Add  ' neue Tabelle erstellen ********************* 
        .Range("A2").Resize(Ubound(ArAusgabe), Ubound(ArAusgabe, 2)) = ArAusgabe
    End With
End If
MsgBox "fertig"
Set oDic = Nothing
End Sub

Function TransposeData(ArValues, oDic As Object)
Dim n&, nn&, NewAr()
Redim Preserve NewAr(1 To Ubound(ArValues, 2), 1 To Ubound(ArValues))
For n = Lbound(ArValues, 2) To Ubound(ArValues, 2)
    For nn = Lbound(ArValues) To Ubound(ArValues)
        NewAr(n, nn) = ArValues(nn, n)
    Next nn
    NewAr(n, 2) = oDic(NewAr(n, 1))
Next n
TransposeData = NewAr
End Function
Gruß Tino

Anzeige
AW: Doppelte Einträge in mehreren Dateien finden
05.04.2013 08:23:49
Toumas
Hallo Tino....
einfach genial.... einfach klasse.... super...
Danke dir vielmals für die super Hilfe.
Viele Grüße
Toumas

AW: Doppelte Einträge in mehreren Dateien finden
05.04.2013 08:27:15
Toumas
Eine Frage habe ich noch leider...
Warum löscht der mir immer die erste Zeile ?

AW: Doppelte Einträge in mehreren Dateien finden
05.04.2013 09:16:13
Tino
Hallo,
die wird nicht gelöscht, die wird einfach Übergangen da ich davon ausgehe das es die Überschrift ist.
Mit Überschrift müsste so gehen.
Sub Start()
Dim ArData, ArFile(), ArAusgabe(), n&, nn&, nnn&, nCount&, StartRow&
Dim oDic As Object, oApp As Excel.Application
Dim sPath$, tmpFileName$

sPath = "G:\1 Forum\Test2\Test3" 'Pfad anpassen ********** 

sPath = IIf(Right$(sPath, 1) <> "\", sPath & "\", sPath)
tmpFileName = Dir(sPath & "*.xls?", vbNormal)
Do While tmpFileName <> ""
    Redim Preserve ArFile(n)
    ArFile(n) = sPath & tmpFileName
    n = n + 1
    tmpFileName = Dir()
Loop
If n < 1 Then Exit Sub 'keine Datei gefunden ************* 

Set oApp = New Excel.Application

Set oDic = CreateObject("Scripting.Dictionary")
With oApp
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    StartRow = 1
    For n = Lbound(ArFile) To Ubound(ArFile)
        Application.StatusBar = "Lese Datei " & n + 1 & " von " & Ubound(ArFile) + 1
        With .Workbooks.Open(Filename:=ArFile(n), ReadOnly:=True)
            With .Sheets(1) 'evtl. anpassen 
                nn = .Cells(.Rows.Count, 1).End(xlUp).Row
                If nn > 1 Then
                    ArData = .Range("A1", .Cells(nn, 1)).Resize(, 19) 'bis Spalte S 
                End If
            End With
            .Close False
        End With
        If IsArray(ArData) Then
            For nn = StartRow To Ubound(ArData)
                If Not oDic.exists(ArData(nn, 1)) Then
                    nCount = nCount + 1
                    Redim Preserve ArAusgabe(1 To 20, 1 To nCount)
                    For nnn = 2 To Ubound(ArData, 2)
                        ArAusgabe(nnn + 1, nCount) = ArData(nn, nnn)
                    Next nnn
                    ArAusgabe(1, nCount) = ArData(nn, 1)
                End If
                oDic(ArData(nn, 1)) = oDic(ArData(nn, 1)) + 1
            Next nn
            ArData = Empty
            StartRow = 2
        End If
    Next n

    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Quit
End With
Set oApp = Nothing
Application.StatusBar = False
If oDic.Count > 0 Then
    ArAusgabe = TransposeData(ArAusgabe, oDic)
    With ThisWorkbook.Sheets.Add  ' neue Tabelle erstellen ********************* 
        With .Range("A1").Resize(Ubound(ArAusgabe), Ubound(ArAusgabe, 2))
            .Value = ArAusgabe
            .Rows(1).Font.Bold = True
            .EntireColumn.AutoFit
        End With
    End With
End If
MsgBox "fertig"
Set oDic = Nothing
End Sub

Function TransposeData(ArValues, oDic As Object)
Dim n&, nn&, NewAr()
Redim Preserve NewAr(1 To Ubound(ArValues, 2), 1 To Ubound(ArValues))
For n = Lbound(ArValues, 2) To Ubound(ArValues, 2)
    For nn = Lbound(ArValues) To Ubound(ArValues)
        NewAr(n, nn) = ArValues(nn, n)
    Next nn
    NewAr(n, 2) = oDic(NewAr(n, 1))
Next n
NewAr(1, 2) = "Anzahl"
TransposeData = NewAr
End Function
Gruß Tino

Anzeige
AW: Doppelte Einträge in mehreren Dateien finden
05.04.2013 09:27:00
Toumas
Hallo Tino,
danke für deine schnelle Antwort, frag mich nicht warum, aber irgendwie hat es bei mir die Überschrift immer gelöscht. Nachdem ich abgespeichert und Excel erneut gestartet habe, funktioniert es einwandfrei....
Excel und ich sind einfach keine Freunde... merke ich immer wieder ;-)
Danke dir nochmals.

AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 10:34:36
Rudi
Hallo,
ungetestet.
Sammeln der Aktenzeichen aus allen Dateien eines Ordners, Blatt1, Spalte A und in neues Sheet:
Sub aaa()
Dim sFile As String, sPath As String, WKB As Workbook, oDict As Object, rngC As Range
sPath = "c:\test\"  'anpassen
Set oDict = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
sFile = Dir(sPath & "*.xls")
Do While sFile  ""
Set WKB = Workbooks.Open(sPath & sFile)
With WKB.Sheets(1)
For Each rngC In .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
oDict(rngC.Value) = 0
Next
End With
WKB.Close False
sFile = Dir
Loop
With Worksheets.Add
.Cells(1, 1).Resize(oDict.Count) = WorksheetFunction.Transpose(oDict.keys)
End With
End Sub

Gruß
Rudi

Anzeige
AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 10:38:08
Toumas
Hallo Rudi,
werde ich gleich mal testen, danke
Viele Grüße

AW: Doppelte Einträge in mehreren Dateien finden
04.04.2013 10:42:16
Toumas
Hallo Rudi,
bei : .Cells(1, 1).Resize(oDict.Count) = WorksheetFunction.Transpose(oDict.keys)
erscheint der Fehler : Typen unverträglich
Viele Grüße

56 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige