Hilfe zu Makro / Dublettensuche
25.04.2013 14:41:59
Toumas
vor Kurzem habe ich ein paar Fragen zur Dublettensuche eingestellt und von Tino
habe ich das unten aufgeführte Makro erhalten, was auch super funktioniert.
Leider kam mein Chef mal wieder auf eine andere Idee.
Das bestehende Makro sucht mir aus mehreren Dateien die Daten raus, vergleicht diese und schreibt mir diese in der geöffneten Datei neu rein.
Dabei zählt es die Anzahl der Dubletten. Diese Anzahl wurde in einer neu hinzugefügten Spalte aufgeführt.
Da sich mein VBA-Wissen doch sehr beschränkt, habe ich nun folgendes Problem.
Das Makro soll "nur" noch die Daten 1:1 kopieren, ohne dass es irgend welche Dubletten sucht. Auch deren Anzahl bzw. die Ausgabe der Anzahl ist nicht mehr notwendig.
Also so gesehen:
Durchsuche alle Dateien im Laufwerk/Pfad : xxxx/xxxx/xxxx
Kopiere von jeder Datei aus einem bestimmten Karteireiter die Spalten
A2 - Fxxxxx (jede in der ein Wert vorhanden ist, leere Zeilen sollen nicht kopiert werden) und füge dies hier unter Tabelle XXXX ab A2 (bis Fxxx)ein.
Ich habe zwar eine Anfängerlösung für mich gefunden, aber dazu muss ich immer die entsprechende Datei nebenher von Hand öffnen und dann mein Makro starten...
Daher dachte ich, dass man vielleicht das unten aufgeführte Makro entsprechend ändern könnte.
Vielen Dank im Voraus
Toumas
Sub DuplikatsucheMasterliste()
Dim ArData, ArFile(), ArAusgabe(), n&, nn&, nnn&, nCount&
Dim oDic As Object, oApp As Excel.Application
Dim sPath$, tmpFileName$
sPath = "\\aaaaa\bbbbb\ccccc\ddddd\eeeee\fffff"
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
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
'Daten in Tabelle1 einfügen
'ArData = TransposeData(oDic.keys)
ArAusgabe = TransposeData(ArAusgabe, oDic)
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
.Range("A2").Resize(UBound(ArAusgabe), UBound(ArAusgabe, 2)) = ArAusgabe
'Daten in eine neue Tabelle einfügen
'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"
'Call Makro2
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