Office: Array unter Bedingung füllen

OfficeUser · 7. Januar 2013

Hallo Forengemeinde,

Ich habe folgende Ausgangstabelle:
Tabelle1

A B C
2 Status Nr Name
3 001 Mustermann
4 001 Mustermann
5 x 002 Musterfrau
6 x 002 Musterfrau
7 003 Musterkind
8 003 Musterkind
Excel Tabellen im Web darstellen >>

:)

EarlFred · 9. Januar 2013

Hallo Wübbo,

Code:

arrKundenNr = wksD.Range("A2:B" & letzte)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Die Spalte A in das Array mit einbinden (dauert unmerklich länger) und hier auf "x" prüfen:

Code:

If arrKundenNr(L, 1) = "x" then
If Not scrDic.exists(arrKundenNr(L, 2)) Then
scrDic.Add arrKundenNr(L, 2), L
objArrLst.Add arrKundenNr(L, 2)
End If
end if
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Grüße
EarlFred

EarlFred · 9. Januar 2013

...weiter im Text:

Warum bremsen, wenn doch Tempo gefragt ist?
Code:

For L = LBound(arrKundenNr, 1) To UBound(arrKundenNr, 1)

Next
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Dieser Block ist schlichtweg unnütz.

Nächste Bremse:
Code:

'Listboxfüllen
For L = LBound(arrKundenNr, 1) To UBound(arrKundenNr, 1)

arrKunde(L, 2) = arrKundenNr(L)
arrKunde(L, 1) = wksD.Cells(Application.Match(arrKundenNr(L), wksD.Range("B2:B" & letzte), 1), "C").Value

Next
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wie vor: Die Spalte C mit in Array aufnehmen und Namen gleich mit auslesen, anstelle umständlich im Worksheet danach zu suchen.

Hier zur Sicherheit dann ein zweites Mal nach anderem Kriterium sortieren (ebenfalls wegen Temporeduzierung?)?? *wink.gif*
Code:

QuickSortMultiDim arrKunde, 2 '***Modul aufrufen um nach Namen zu sortieren
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Grüße
EarlFred

chris-kaiser · 9. Januar 2013

Hi

Code:

Public Sub UserForm_Initialize()
Dim objArrLst
Dim arrKunden()
Dim L As Long
Dim scrDic
Dim wksD As Worksheet
Dim letzte As Long
Dim c As Integer

Set wksD = ThisWorkbook.Worksheets("Datenbank")
Set objArrLst = CreateObject("System.collections.arraylist")
Set scrDic = CreateObject("Scripting.dictionary")
arrKunden = wksD.Range("A2", wksD.Cells(Rows.Count, "B").End(xlUp))

For L = 1 To UBound(arrKunden)
If Not scrDic.exists(arrKunden(L, 2)) And arrKunden(L, 1) x Then
scrDic.Add arrKunden(L, 2), L
objArrLst.Add arrKunden(L, 2)
End If
Next
On Error GoTo 0
Erase arrKunden
With objArrLst
.Sort
arrKunden = .ToArray
End With
'Jetzt ist arrKunden sortiert ohne Duplikate
Set objArrLst = Nothing
Set scrDic = Nothing
'was auch immer du da weiter machen möchtest

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

das gibt dir nur mal alle sortiert die ein X haben aus (die Nummern)
wenn es schnell gehen sollte.... dann verwende für das sortieren der Namen doch auch gleich die System.collections.arraylist.. möglicherweise machsr du das ja auch in deinem QuickSortMultiDim wie sollte das Endergebnis eigentlich aussehen?

*grins *grins Ich hätte wohl keine Kaffeepause machen sollen....

wuebbo · 9. Januar 2013

Besten Dank es läuft wie ich es wollte.

Dieses habe ich in meinem Code soweit ergänzt:
Code:

arrKundenNr = wksD.Range("A2:C" & letzte)

On Error Resume Next

'**Quelle VBA - Array unter Bedingung füllen - MS-Office-Forum
For L = 1 To UBound(arrKundenNr)
If Not scrDic.exists(arrKundenNr(L, 2)) And arrKundenNr(L, 1) "x" Then
scrDic.Add arrKundenNr(L, 2), L
objArrLst.Add arrKundenNr(L, 2)
End If
Next
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Gelöscht wurde:
Code:

For L = LBound(arrKundenNr, 1) To UBound(arrKundenNr, 1)

Next
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Allerdings komme ich mit der Optimierung sonst nicht weiter!
Ich glaube dass er mir hier den Array durcheinander schmeißt, weswegen ich Ihn nicht mehr so einfach übergeben kann:
Code:

On Error GoTo 0
Erase arrKundenNr
With objArrLst
.Sort
arrKundenNr = .ToArray
End With
'Jetzt ist arrKundenNr sortiert ohne Duplikate
Set objArrLst = Nothing
Set scrDic = Nothing
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

(hier werden Duplikate gelöscht, Leere Zeilen gelöscht und nach den Nummern sortiert)

Dass Problem taucht dann nämlich hier auf:
Code:

For L = LBound(arrKundenNr, 1) To UBound(arrKundenNr, 1)

arrKunde(L, 2) = arrKundenNr(L, 1)
arrKunde(L, 1) = wksD.Cells(Application.Match(arrKundenNr(L), wksD.Range("B2:B" & letzte), 1), "C").Value

Next
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Bei arrKundenNr(L,1) sagt er folgenden Fehler:
Laufzeitfehler 9
Index außerhalb des gültigen Bereichs

Wenn ich den Code so stehen lasse läuft es wunderbar:
Code:

For L = LBound(arrKundenNr, 1) To UBound(arrKundenNr, 1)

arrKunde(L, 2) = arrKundenNr(L)
arrKunde(L, 1) = wksD.Cells(Application.Match(arrKundenNr(L), wksD.Range("B2:B" & letzte), 1), "C").Value

Next
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Und ich weiß mal wieder nicht woran es liegen kann.

Zu Info der Modul QuickSortMultiDim hat folgenden Code:
Code:

' Quelle vb@rchiv · Tipps & Tricks · 2-dimensionales Array nach beliebiger Spalte sortieren
' vSort: 2-dimensionales Array
' index: Spalte, nach der sortiert werden soll (1, 2, 3, ...)
Public Sub QuickSortMultiDim(vSort As Variant, _
Optional ByVal index As Integer = 1, _
Optional ByVal lngStart As Variant, _
Optional ByVal lngEnd As Variant)

' Wird die Bereichsgrenze nicht angegeben,
' so wird das gesamte Array sortiert

If IsMissing(lngStart) Then lngStart = LBound(vSort)
If IsMissing(lngEnd) Then lngEnd = UBound(vSort)

Dim i As Long
Dim j As Long
Dim h As Variant
Dim x As Variant
Dim u As Long
Dim lb_dim As Integer
Dim ub_dim As Integer

' Anzahl Elemente pro Datenzeile
lb_dim = LBound(vSort, 2)
ub_dim = UBound(vSort, 2)

i = lngStart: j = lngEnd
x = vSort((lngStart + lngEnd) / 2, index - 1)

' Array aufteilen
Do

While (vSort(i, index - 1) < x): i = i + 1: Wend
While (vSort(j, index - 1) > x): j = j - 1: Wend

If (i
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

chris-kaiser · 9. Januar 2013

Hi,

wie soll das Endergebnis aussehen*wink.gif*
Mir ist nicht klar warum zuerst nach Nummer sortieren, dann Array wieder zusammenbasteln und dann wiederum nach Namen sortieren.
Brauchst Du danach zwei Arrays? eines mit sortierten Nummern und eines mit sortierten Namen?. oder doch nur eines?
Hilfreich wäre eine kleine Demomappe mit Dummydaten, damit wir erkennen können, für was Du das brauchst, bzw. welche Möglichkeiten deine (User)Form bieten sollte.

Das collections.arraylist kann nur eindimensionale Arrays verarbeiten,
obwohl jetzt Spalte A mitgenommen wurde wird auch jetzt nur Spalte B ins collections.arraylist gegeben, Spalte A habe ich nur aufgenommen damit nach X aussortiert werden kann. Was wiederum die Frage aufwirft warm wird die arraylist verwendet wenn Du ohnehin einen Sortieralgorithmus zur Verfügung hast.?

Irgendwie sind da Codes zusammenkopiert worden, die für sich alleine gut brauchbar sind, aber im Zusammenspiel für mich nicht verständliche Redundanzen aufweisen.

wuebbo · 9. Januar 2013

So hier haben wir mal eine Beispiel Datei.

Folgendes soll dabei passieren:

Tabelle Kostenstelle:

Doppelklick oder rechts klick auf Spalte Kunde öffnet Userform mit den Kunden aus der Datenbank alphabetisch geordnet.

Dann kann ein Kunde ausgewählt werden dabei wir die Box Projekte geladen mit den Projekten des Kunden

Bei Auswahl eines Projektes wird die Box mit den dazugehörigen Kategorien geladen

Die Projekte und Kategorien können dabei in der Userform beschriftet werden

Kunden können durch die Extra Abfrage ausgeblendet werden, stehen aber trotzdem weiterhin in der Datenbank. !!wichtig.!!

Tabelle Datenbank:
Hier erfolgt eine Aktualisierung der Kunden mit einem anderen Programm. daher dürfen hier keine Kunden gelöscht werden.

Die Codes sind, wie Chris bereits mit Adleraugen bemerkt hat, aus mehreren Bereichen zusammengebastelt und mit einer Priese Unwissenheit verfeinert worden. Allerdings Funktioniert es (Anflug von Übermut)
Also ich hoffe dass Ihr dort durchsteigt.

chris-kaiser · 10. Januar 2013

Hi,

Code:

Sub KundeBox()
Dim objArrLst
Dim arrKunde() As Variant
Dim L As Long
Dim scrDic, TempArr
Dim wksD As Worksheet
Dim letzte As String, strTmp As String
Dim c As Integer, i As Integer
Const Trenner As String = "#"
Set wksD = ThisWorkbook.Worksheets("Datenbank")
Set scrDic = CreateObject("Scripting.dictionary")
letzte = wksD.Cells(Rows.Count, "B").End(xlUp).Row
arrKunde = wksD.Range("A2:C" & letzte)
For L = 1 To UBound(arrKunde)
strTmp = ""
For i = 1 To UBound(arrKunde, 2)
strTmp = strTmp & arrKunde(L, i) & Trenner
Next
If UCase(arrKunde(L, 1)) = "X" Then
scrDic(strTmp) = 0
End If
Next
TempArr = scrDic.keys
Erase arrKunde
'Größe des arrays Kunde setzen
ReDim Preserve arrKunde(scrDic.Count - 1, 1)
For L = 0 To scrDic.Count - 1
arrKunde(L, 1) = Split(TempArr(L), Trenner)(1)
arrKunde(L, 0) = Split(TempArr(L), Trenner)(2)
Next
Set scrDic = Nothing
QuickSortMultiDim arrKunde, 2 '***Modul aufrufen um nach Namen zu sortieren

With Me.Kunde
.ColumnCount = 2
.ColumnWidths = "4cm;1cm"
.List = arrKunde
End With
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

das müsste auch 10.000 in 0,1 bis 1 sek einlesen. (geschätzt) *wink.gif*

Nur habe ich auch nur die zwei Spalten übernommen? warum du in der Listbox 3 gehabt hast?

deine Match columns gehören dann natürlich angepasst, aber das habe ich jetzt nicht weitergemacht, da fehlt mir einfach der Durchblick was da alles so passieren sollte..., ich würde alles über das Array machen..

In weitere Folge können also bei meinem Code jetzt Fehler sein da die Indices (Indexe) angepasst werden müssten.

Office: Array unter Bedingung füllen

Array unter Bedingung füllen

Array unter Bedingung füllen

Array unter Bedingung füllen

Array unter Bedingung füllen

Array unter Bedingung füllen - Similar Threads - Array Bedingung füllen

Mittelwert aus mehreren Spalten als dynamisches Array

Adressen in eine Zelle bei Übereinstimmung eindeutiger Werte einer anderen Spalte

Zahlendubletten im Array

Array aus Excel Tabelle einlesen Word VBA

Summenteilergebnis eines Arrays als Array darstellen

Formel bei Veränderung von dynamischem Array "mitziehen"?

Array-Funktion mit VBA in Zelle schreiben

	A	B	C
2	Status	Nr	Name
3		001	Mustermann
4		001	Mustermann
5	x	002	Musterfrau
6	x	002	Musterfrau
7		003	Musterkind
8		003	Musterkind