Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1212to1216
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

Geht das auch schneller...?

Geht das auch schneller...?
abu
Hallo zusammen,
habe mal wieder ein Problem und hoffe ihr koennt mir helfen.
Ich muss eine Datei durchsuchen und zwar wie folgt.
1 ich setze ein Filter in Spalte A
2 in Spalte B koennen 11 verschiede Werte stehen und fuer jeden Wert:
3 muss ich in Spalte C zaehlen wie viele verschiedene Werte stehen
Das ganze muss ich fuer ca. 2000 verschiede Werte in Spalte A machen und die Datei hat ca. 30.000 Zeilen. Bei mir dauert das ganze ca. 10min. Ich vermute mal das kann man auch besser loesen.
Hat jemand vllt. eine Idee wie?
Hier mein Ansatz fuer den ersten Wert in Spalte A und der erste moegliche Wert in Spalte B. das ganze habe ich dann noch 10mal fuer die anderen moeglichen Werte in Spalte B.
Wuerde mich ueber Antwort freuen.
Beste Gruesse
Abu
            For i = 1 To UBound(ldaten)
z = SuchenStock(ldaten(i, 1))
If z  -1 Then
Selection.AutoFilter Field:=1, Criteria1:=ldaten(i, 1)
Selection.AutoFilter Field:=2, Criteria1:="DYNPCKA - pick area A"
If sichtbar  1 Then
Set oFilter1 = CreateObject("Scripting.dictionary")
For Each rngG1 In Range(Cells(2, 3), Cells(Rows.Count, 3).End(xlUp))
If Rows(rngG1.Row).Hidden = False Then
oFilter1(rngG1.Value) = rngG1.Value
End If
Next
ldaten(i, 13) = oFilter1.Count
End If

AW: Geht das auch schneller...?
19.05.2011 10:34:34
Rudi
Hallo,
ich denke mal die Filterei friss die Performance. Bastel dir doch den Key für das Dic. entsprechend zusammen.
mal als Ansatz:
Sub ttt()
Dim rngC As Range, oFilter As Object, strKey As String
Dim vntTmp, arr
Set oFilter = CreateObject("Scripting.Dictionary")
For Each rngC In Range(Cells(2, 3), Cells(Rows.Count, 3).End(xlUp))
strKey = rngC.Offset(, -2) & "_" & rngC.Offset(, -1) & "_" & rngC
If oFilter.exists(strKey) Then
vntTmp = oFilter(strKey)
vntTmp(3) = vntTmp(3) + 1
oFilter(strKey) = vntTmp
Else
oFilter(strKey) = Array(rngC.Offset(, -2), rngC.Offset(, -1), rngC, oFilter(strKey) + 1)
End If
Next
With Worksheets.Add
.Cells(2, 1).Resize(oFilter.Count, 4) = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(oFilter.items))
End With
End Sub

Gruß
Rudi
Anzeige
AW: Geht das auch schneller...?
19.05.2011 12:12:24
abu
Hallo Rudi,
ja hast recht die Filtei dauert ewig....
Hab noch probleme zu verstehen wohin du mich schicken willst (bin ja nicht so der VBA Profi).
Also Schleife laeuft alle Zeilen ab.
strKey = SpalteA_SpalteB_SpalteC
Dann pruefe ob der neue strKey bereits in oFilter ist - aber wann wird strKey an oFilter uebergeben?
Wenn ja dann ? uebergebe oFilter(strKey) an vntTmp (das is ein String)
dann addiere 1 (zu nem String)? vntTmp(3) hier kommt der Fehler Ich denke mal mich muss vntTmp noch dimensionieren...
Puuhh, hast du vllt. lust mir das ein bissel zu erklaeren?
Gruss
abu
Anzeige
AW: Geht das auch schneller...?
19.05.2011 12:51:45
Rudi
Hallo,
so schlimm ist das gar nicht.
Grundlage ist, dass die Elemente (Items) eines Dictionarys beliebige Daten beinhalten können, auch Arrays. Ich bilde also den Schlüssel aus A, B und C ( Form A_B_C) und schreibe A,B und C + einem Zähler als Array in das Dic. Am Ende haben wir dann lauter Arrays im Dic.
Der Trick am Ende besteht darin, die Items 2x zu transponieren. Dadurch wird aus dem eindimensionalen Array, das eindimensionale Arrays enthält ein zweidimensionales Array, das in die Tabelle geschrieben wird.
Hier nochmal korrigierter und kommentierter Code:
Sub ttt()
Dim rngC As Range, oFilter As Object, strKey As String
Dim vntTmp, arr
Set oFilter = CreateObject("Scripting.Dictionary")
'Bereich durchgehen
For Each rngC In Range(Cells(2, 3), Cells(Rows.Count, 3).End(xlUp))
'Schlüssel aus A_B_C
strKey = rngC.Offset(, -2) & "_" & rngC.Offset(, -1) & "_" & rngC
If oFilter.Exists(strKey) Then
'Schlüssel bereits vorhanden? Dann Wert (Array) einlesen
vntTmp = oFilter(strKey)
vntTmp(3) = vntTmp(3) + 1 'Anzahl der Vorkommen +1
oFilter(strKey) = vntTmp  'Wert wieder zurückschreiben
Else
'Schlüssel noch nicht vorhanden, dann Array(A, B, C,1) in Dic. schreiben
oFilter(strKey) = Array(rngC.Offset(, -2), rngC.Offset(, -1), rngC, 1)
End If
Next
'Blatt einfügen und Werte(Items) des Dic. reinschreiben
With Worksheets.Add
.Cells(2, 1).Resize(oFilter.Count, 4) = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(oFilter.items))
End With
End Sub

Gruß
Rudi
Anzeige
AW: Geht das auch schneller...?
19.05.2011 13:29:05
abu
Hallo Rudi,
danke hilft aber habs noch nicht ganz...
Er zickt noch hier:
    .Cells(2, 1).Resize(oFilter.Count, 4) = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(oFilter.items))
Fehler Typ Missmatch
Dann wuerde ich mir gerne ansehen wie die Werte sich veraendern indem ich die Zeile einzelnd _ durchlaufe. Leider zickt er dann aber auch

vntTmp(3) = vntTmp(3) + 1 'Anzahl der Vorkommen +1

Wenn ich das komplett laufen lasse, dann erst am Ende.
Wieso ist das so?
Gruss
abu
Anzeige
Limitationen der Transpose-Methode
19.05.2011 14:16:25
abu
Hallo Rudi,
da ich mir das Ergebnis nicht anschauen kann, verstehe ich es auch noch nicht so ganz. Habe jetzt nachgelesen das die Transpose-Methode auch grenzen hat. An diese stosse ich wohl.
Limitationen der Transpose-Methode
If you decide to use Excel's Transpose method instead of the TransposeDim function to transpose  _
the array, you should be aware of the following limitations with the Transpose method:
The array cannot contain an element that is greater than 255 characters.
The array cannot contain Null values.
The number of elements in the array cannot exceed 5461. 
Koennen wir das irgendwie umgehen oder anders auswerten? Oder ist dein Ansatz damit hinfaellig?
Wuerde mich ueber Antwort freuen.
Gruss
Abu
Anzeige
AW: Limitationen der Transpose-Methode
19.05.2011 14:32:43
Rudi
Hallo,
dann schaufeln wir das 'von Hand' in ein Array
Sub ttt()
Dim rngC As Range, oFilter As Object, strKey As String
Dim vntTmp, arrDaten(), i As Long, j As Long, arrItems
Set oFilter = CreateObject("Scripting.Dictionary")
'Bereich durchgehen
For Each rngC In Range(Cells(2, 3), Cells(Rows.Count, 3).End(xlUp))
'Schlüssel aus A_B_C
strKey = rngC.Offset(, -2) & "_" & rngC.Offset(, -1) & "_" & rngC
If oFilter.Exists(strKey) Then
'Schlüssel bereits vorhanden? Dann Wert (Array) einlesen
vntTmp = oFilter(strKey)
vntTmp(3) = vntTmp(3) + 1 'Anzahl der Vorkommen +1
oFilter(strKey) = vntTmp  'Wert wieder zurückschreiben
Else
'Schlüssel noch nicht vorhanden, dann Array(A, B, C,1) in Dic. schreiben
oFilter(strKey) = Array(rngC.Offset(, -2), rngC.Offset(, -1), rngC, 1)
End If
Next
'Items in Array umwandeln
arrItems = oFilter.items
ReDim arrDaten(1 To oFilter.Count, 1 To 4)
For i = 1 To oFilter.Count
For j = 1 To 4
arrDaten(i, j) = arrItems(i - 1)(j - 1)
Next j
Next i
'Blatt einfügen und Werte(Items) des Dic. reinschreiben
With Worksheets.Add
.Cells(2, 1).Resize(oFilter.Count, 4) = arrDaten
End With
End Sub

Gruß
Rudi
Anzeige
Hab mich wohl schlecht ausgedrueckt
19.05.2011 15:07:18
abu
Hallo Rudi,
das ist schon genial und auch wesentlich schneller. Aber ich komme noch nicht da aus wo ich will:
Das steht irgendwo in der Tabelle:
BUN00003	DYNPCKC - pick area C parts	R41-010-F-02
BUN00003	DYNPCKC - pick area C parts	R43-020-A-01
BUN00003	DYNPCKC - pick area C parts	R44-021-B-01
BUN00003	DYNPCKC - pick area C parts	R44-021-B-01
BUN00003	DYNPCKC - pick area C parts	R44-021-B-01
Das Ergebnis muss also 3 sein, weil Item BUN00003 fuer DYNPCKC - pick area C parts in 3 verschiedenen Loaktionen steht.
Dein Ergebnis ist aber:
BUN00003	DYNPCKC - pick area C parts	R41-010-F-02	1
BUN00003	DYNPCKC - pick area C parts	R43-020-A-01	1
BUN00003	DYNPCKC - pick area C parts	R44-021-B-01	3
Vllt. hab ich mich auch falsch ausgedrueckt aber ich muss nur das wissen:
BUN00003 fuer DYNPCKC - pick area C parts = 3
Wenn ich das dann irgendwann habe, bleibt noch die Frage wie ich das jezt noch meinem Array was ich schon habe zuweise. Das hat ca 2000 items.
Soll ich die Tabelle durchlaufen und im Array suchen lassen? Das waere im schlechtesten Fall 2000 x 11
Die 2000 Werte habe ich aber auch schon in einer Tabelle stehen, soll ich da suchen lassen?
Jedenfalls schon mal danke fuer die Muehe die du dir schon gemacht hast.
Beste Gruesse
abu
Anzeige
AW: Hab mich wohl schlecht ausgedrueckt
19.05.2011 16:39:56
Rudi
Hallo,
ich glaub ich habe verstanden.
Sub ttt()
Dim rngC As Range, oFilter As Object, strKey As String
Dim vntTmp, arrDaten(), i As Long, j As Long, arrItems
Set oFilter = CreateObject("Scripting.Dictionary")
'Bereich durchgehen
For Each rngC In Range(Cells(2, 3), Cells(Rows.Count, 3).End(xlUp))
'Schlüssel aus A_B_C
strKey = rngC.Offset(, -2) & "_" & rngC.Offset(, -1) & "_" & rngC
oFilter(strKey) = Array(rngC.Offset(, -2), rngC.Offset(, -1))
Next
'Items in Array merken
arrItems = oFilter.items
oFilter.RemoveAll
'Anzahl A_B ermitteln
For i = 0 To UBound(arrItems)
strKey = arrItems(i)(0) & "_" & arrItems(i)(1)
If oFilter.exists(strKey) Then
vntTmp = oFilter(strKey)
vntTmp(2) = vntTmp(2) + 1
oFilter(strKey) = vntTmp
Else
oFilter(strKey) = Array(arrItems(i)(0), arrItems(i)(1), 1)
End If
Next i
arrItems = oFilter.items
ReDim arrDaten(1 To oFilter.Count, 1 To 3)
For i = 1 To oFilter.Count
For j = 1 To 3
arrDaten(i, j) = arrItems(i - 1)(j - 1)
Next j
Next i
'Als Bsp. Blatt einfügen und Werte(Items) des Dic. reinschreiben
With Worksheets.Add
.Cells(2, 1).Resize(oFilter.Count, 3) = arrDaten
End With
End Sub

Wenn das passt, müssen wir sehen, wie es weitergeht.
Du kannst aus der Prozedur aber auch eine Funktion machen, die dir ein Array erstellt, das du weiter verarbeitest.
Schema:
Function MeinArray()
'Code von oben, außer Worksheet.Add
MeinArray=arrDaten
End Function

In deinem Code sowas wie
Dim Arr
Arr=MeinArray
For i=1 to ubound(arr)
'Mach was
Next
Gruß
Rudi
Anzeige
Danke Rudi!!!
20.05.2011 11:35:24
abu
Hallo Rudi,
so habs nun. Habe deinen Vorschlag umgesetzt und die Prozedur in eine Funktion geschrieben. Anschliessend lasse ich in meinem Array nach dem Wert suchen und weise die Werte der richtigen stelle zu.
1000 Dank fuer deine Unterstuezung. Du hast es von ueber 10min auf ca. 30sek reduziert.
Jetzt muss ich nur noch richtig verstehen wie ich es auf andere Probleme anwenden kann da ich noch weiter Makros habe wo ich ungefaehr 100.000 Zeile verarbeite, dauer ca. 25 min mit meiner Methode.
Eine Frage habe ich aber noch: Wieso bekomme ich immer Fehlermeldungen wenn ich Deinen Code Zeile fuer Zeile ablaufe?
Beste Gruesse
abu
Anzeige
AW: Danke Rudi!!!
20.05.2011 12:07:40
Rudi
Hallo,
warum du Fehler bekommst, weiß ich nicht.
Ich hab aber selbst noch einen gefunden.
Function MeinArray(wksDaten As Worksheet)
Dim rngC As Range, oFilter As Object, strKey As String
Dim vntTmp, arrDaten(), i As Long, j As Long, arrItems
Set oFilter = CreateObject("Scripting.Dictionary")
'Bereich durchgehen
With wksDaten
For Each rngC In .Range(.Cells(2, 3), .Cells(Rows.Count, 3).End(xlUp))
'Schlüssel aus A_B_C
strKey = rngC.Offset(, -2) & "_" & rngC.Offset(, -1) & "_" & rngC
oFilter(strKey) = Array(rngC.Offset(, -2).Value, rngC.Offset(, -1).Value)
Next
End With
'Items in Array merken
arrItems = oFilter.items
oFilter.RemoveAll
'Anzahl A_B ermitteln
For i = 0 To UBound(arrItems)
strKey = arrItems(i)(0) & "_" & arrItems(i)(1)
If oFilter.exists(strKey) Then
vntTmp = oFilter(strKey)
vntTmp(2) = vntTmp(2) + 1
oFilter(strKey) = vntTmp
Else
oFilter(strKey) = Array(arrItems(i)(0), arrItems(i)(1), 1)
End If
Next i
arrItems = oFilter.items
ReDim arrDaten(1 To oFilter.Count, 1 To 3)
For i = 1 To oFilter.Count
For j = 1 To 3
arrDaten(i, j) = arrItems(i - 1)(j - 1)
Next j
Next i
MeinArray = arrDaten
End Function
Sub ttt()
Dim arr
arr = MeinArray(ActiveSheet)
End Sub
Anschliessend lasse ich in meinem Array nach dem Wert suchen und weise die Werte der richtigen stelle zu.

Was machst du? Wenn du deinem Array die Anzahl, also MeinArray(x,3) zuweisen willst, solltest du das Dictionary behalten, da du ja die Keys direkt ansprechen kannst. das ist viel schneller.
Könnte so aussehen:
Function MeinArray(wksDaten As Worksheet)
Dim rngC As Range, oFilter As Object, strKey As String
Dim vntTmp, arrDaten(), i As Long, j As Long, arrItems
Set oFilter = CreateObject("Scripting.Dictionary")
'Bereich durchgehen
With wksDaten
For Each rngC In .Range(.Cells(2, 3), .Cells(Rows.Count, 3).End(xlUp))
'Schlüssel aus A_B_C
strKey = rngC.Offset(, -2) & "_" & rngC.Offset(, -1) & "_" & rngC
oFilter(strKey) = Array(rngC.Offset(, -2).Value, rngC.Offset(, -1).Value)
Next
End With
'Items in Array merken
arrItems = oFilter.items
oFilter.RemoveAll
'Anzahl A_B ermitteln
For i = 0 To UBound(arrItems)
strKey = arrItems(i)(0) & "_" & arrItems(i)(1)
oFilter(strKey) = oFilter(strKey) + 1
Next i
Set MeinArray = oFilter
End Function
Sub ttt()
Dim arr
Set arr = MeinArray(Sheets("Daten"))
MsgBox arr(Sheets("Daten").Cells(2, 1) & "_" & Sheets("Daten").Cells(2, 2))
End Sub
Gruß
Rudi
AW: Danke Rudi!!!
23.05.2011 15:56:18
abu
Hallo Rudi,
noch mal grossen Dank das du dir noch mehr Muehe gemacht hast.
Seh ich das richtig das du lediglich das aktive Arbeitsblatt an die Funktion uebergibst, sonst hast du doch nichts geaendert?
Letztlich bin ich bei meiner Version geblieben, ob ich nun 5sek. spare ist mir nicht so wichtig.
Hab nun auch deinen Weg auf ein anderes Problem angewendet.
2 Arbeitsblaetter mit 100.000 Zeilen werden nun in insgesamt 42sek. verarbeitet wobei deine Methode gleich 2 mal angewendet wird.
Viel gerlernt!
Gruss
Abu
5 Sekunden sparen
23.05.2011 16:42:16
Rudi
Hallo,
sieh das mal prozentual ;-)
das du lediglich das aktive Arbeitsblatt an die Funktion uebergibst, sonst hast du doch nichts geaendert?

In der ersten ja. Du kannst aber auch jedes andere Sheet übergeben. Muss nicht aktiv sein.
In der zweiten Version wird das Dictionary-Objekt übergeben, kein Array.
Gruß
Rudi

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige