Dublettensuche / Problem mit dem Einfügen
18.04.2013 09:51:59
Toumas
ich hatte am 04.04.2013 den Beitrag zur Dublettensuche inklusive kopieren der Daten eingestellt. Tino war so freundlich und hat mir ein super geniales Makro geschrieben, was perfekt funktioniert hat.
Mittlerweile bin ich auch stolz auf mich dass ich, ohne Hilfe, eine variable Pfadangabe eingebaut habe (ja ich weiß, ist nicht wirklich DAS Ereignis..... aber ich bin Anfänger..... ;-) , seht es mir also nach, wenn ich da stolz wie Oskar bin )
Nun habe ich das Problem, dass er nicht mehr die Spalten A-S sondern "nur" noch die A-F kopieren soll, da ich gemerkt habe, dass er mir sonst meine Formeln in den Spalten G-S überschreibt.
Meine Idee (zumindest was ich so dachte habe ich mal in das beigefügte Makro eingetragen.... Aber irgendwie funktioniert es nicht und bei solchen Makros steigt momentan einfach mein Gehirn noch aus ;-)
Ich danke euch schon mal im Voraus für eure Mühen.
Viele Grüße
Toumas
Sub DuplikatSucheVariablePfadangabe()
Dim ArData, ArFile(), ArAusgabe(), n&, nn&, nnn&, nCount&
Dim oDic As Object, oApp As Excel.Application
Dim sPath$, tmpFileName$
Dim Eingabe As String
'WIE GESAGT: DIE INPUTBOX IST AUF MEINEM MIST GEWACHSEN, DAS ORIGINAL IST DIE VERSION UNTEN _
MIT DEM SPath
Eingabe = InputBox("Bitte hier den Pfad vollständigen Pfad angeben")
'sPath = IIf(Right$(sPath, 1) "\", sPath & "\", sPath)
Eingabe = IIf(Right$(Eingabe, 1) "\", Eingabe & "\", Eingabe)
tmpFileName = Dir(Eingabe & "*.xls?", vbNormal)
Do While tmpFileName ""
ReDim Preserve ArFile(n)
ArFile(n) = Eingabe & 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
' HIER IST MEIN PROBLEM, ICH DACHTE ICH KANN DIE ZAHL EINFACH VON 19 AUF 6 ÄNDERN UND ER _
MACHT MIR NUR NOCH BIS SPALTE F ALLES, ODER MUSS ICH NOCH/ZUSÄTZLICH DIE Preserve ArAusgabe(1 To 20) ÄNDERN ?
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("Scan Tag alle") 'evtl. anpassen
'DAS HIER HABE ICH AUCH REINGEBAUT; WEIL ICH DACHTE, DER LÖSCHT MIR MIT DER UNTEN AUFGEFÜ _
HRTEN PROZEDUR ALLE ZELLEN AB A2
Range("A2:F60000").Select
Selection.ClearContents
' DAS HIER GEHÖRT ZUM ORIGINAL
'.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"
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