Dublettensuche die Zweite...
18.04.2013 13:45:24
Toumas
ich hatte wie heute kurz ebenfalls aufgeführt, die Dublettensuche als Makro von Tino erhalten (Makro füge ich unten nochmals bei, die restlichen Zusammenhänge kann man aus den einzelnen Postings besser entnehmen)
Nun kamen die Herrschaften auf die Idee, dass nicht (nur) die Anzahl der Dubletten , sondern auch von jeder einzelnen Gewichtung die Anzahl eingefügt werden soll.
Wie in der Beispieldatei erhalten die Datensätze eine gewisse Gewichtung
10, 20, 30, 40 usw. wobei 10 das wichtigste ist (sieht man auch nachher in der Datei, dass die 10er rot sind, die 20er gelb und der Rest grün)Die Gewichtung wird Anhand der Bezeichung festgelegt und mittels einer jeweils bedingten Formatierung sichtbar gemacht.
Die Anzahl der Gewichtung (Habe ich in der Beispieldatei nochmals beschrieben) soll immer in die Spalte dahinter also : Gewichtung 10 steht in H(und die Anzahl der Vorgänge steht nachher in I, Gewichtung 20 steht in J und die Anzahl steht in K usw. usw.) eingefügt werden.
Da ich es gerade mal geschafft habe in das Makro von Tino meine Änderungen ( Variable Eingabe des Suchpfades und Kopieren/Einfügen nur noch bis F)
einzuarbeiten, wäre ich sehr dankbar, wenn Ihr mir (mal wieder) unter die Arme greifen könntet. Falls so was gar nicht möglich ist, oder nur mit sehr großen Aufwand, dann sagt es mir bitte.
Die Datei hat ein Arbeitskollege für mich hochgeladen, der einen Vollzugriff auf das Internet hat, falls ihr noch eine andere Datei oder so was benötigt, wird es etwas schwer, da ich dies in der Regel nur von meinem privaten Rechner, tätigen kann.
https://www.herber.de/bbs/user/84930.xlsx
!! Ich brauche nicht sofort eine Antwort, vor allem, da ich erst mal bis nächste Woche Dienstag auf einen Lehrgang muss, also wenn Ihr Lust, Zeit und Laune habt da euch etwas zu überlegen wäre es super genial.
Vielen Dank im Voraus (auch wenn es bei diesem Wunsch mit einem einfachen Danke schon nicht mehr getan ist)
Wie oben erwähnt, seit bitte ehrlich und sagt auch, wenn so ein Wunsch zu weit geht und es einfach zu viel Arbeit/Mühe "kosten" würde.
Viele Grüße
Toumas
Anbei noch das Makro (mit meinen Veränderungen)
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
'Meine Änderung der individuellen Pfadangabe
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
'ArData = .Range("A2", .Cells(nn, 1)).Resize(, 19) 'bis Spalte S
'Meine Änderung der Spalte bis F
ArData = .Range("A2", .Cells(nn, 1)).Resize(, 6) 'bis Spalte f
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)
'Auch meine Änderung, dass nur bis G eingefügt wird
ReDim Preserve ArAusgabe(1 To 7, 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
Range("A2:F60000").Select
Selection.ClearContents
'.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