Office: Array befüllen und durchsuchen

DubWay · 21. Februar 2016

Hallo Leute,
stehe vor einem kleinen Problem, bei dem ich nicht weiterweiß.

Ich habe eine Tabelle, in der in der ersten Spalte jeweils Benutzer eingetragen werden. Diese kommen jedoch häufiger vor. Jetzt möchte ich sämtliche Zeilen durchgehen und jeden Benutzer nur einmal in ein Array speichern.

Leider scheitert es bisher an der Dimensionierung laut Fehlermeldung. Habe schon weiter Variationen versucht jedoch immer mit der selben Fehlermeldung.

Anbei mein Makro
Code:

Sub Suche()

Dim arrArray()
Dim i, j, x As Integer
Dim lngLetzteZeile, lngArrayWert As Long
Dim boolVorhanden As Boolean
Dim strSuchbegriff As String

lngLetzteZeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
boolVorhanden = False

ReDim Preserve arrArray(0)

arrArray(0) = ThisWorkbook.Worksheets("Tabelle1").Cells(1, 1).Value

' Beginn bei Zeile 2, da Anfangsbefüllung notwenig
For i = 2 To lngLetzteZeile

Suchbegriff = ThisWorkbook.Worksheets("Tabelle1").Cells(i, 1).Value

For x = 0 To UBound(arrArray())

If arrArray(x) Like Suchbegriff Then

boolVorhanden = True

End If

Next x

If Not boolVorhanden = True Then

ReDim Preserve arrArray(UBound(arrArray()) + 1)
arrArray(UBound(arrArray()) + 1) = Suchbegriff

End If

Next i

For j = 1 To UBound(arrArray())
MsgBox arrArray(j)
Next j

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

Eine weitere Möglichkeit wäre natürlich mittels Filter alle doppelten Benutzer zu entfernen, in ein Array zu schreiben, Tabelleninhalt löschen und erneut die Daten einlesen. Weiß jetzt jedoch nicht was zeitlich schneller ist.

Code:

ActiveSheet.Range("$A$1:$A$18").RemoveDuplicates Columns:=1, Header:=xlNo
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Wäre nett wenn mir jemand bei dem Array-Problem helfen würde. Die Variante mit dem Filter würde ich gerne vermeiden

Danke schonmal

Gruß Carsten

PS: Denke eine Musterdatei ist nicht notwendig, da darin nur untereinander zB Benutzer A, Benutzer B, Benutzer A, Benutzer C stehen würde

:)

Beverly · 23. Februar 2016

Hi Carsten,

benutze ein Dictionary-Objekt:

Code:

Sub OhneDuplicate()
Dim objDictionary As Object
Dim varBereich As Variant
Dim lngZaehler As Long
Dim arrDaten As Variant
Dim lngLetzteZeile
Set objDictionary = CreateObject("Scripting.Dictionary")
With Worksheets("Tabelle1")
lngLetzteZeile = .Cells(Rows.Count, 1).End(xlUp).Row
varBereich = .Range(.Cells(1, 1), .Cells(lngLetzteZeile, 1))
End With
' Schleife über alle Werte des Bereichs
For lngZaehler = LBound(varBereich) To UBound(varBereich)
' Eintrag wird nur übernommen wenn er im DictionaryObject noch nicht enthalten ist
objDictionary(varBereich(lngZaehler, 1)) = 0
Next
' Werte in ein Array übergeben
arrDaten = objDictionary.keys
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

haklesoft · 23. Februar 2016

Hallo Carsten,

wenn Du eine Collection befüllst und Deine Suchwörter als Index einfügst, bekommst Du für jede Doublette einen Fehler und kannst darauf reagieren.

Auch mit dem Dictionary-Objekt lässt sich so etwas realisieren.

Ich habe heute keinen PC zur Hand, kann also kein Beispiel liefern. *frown.gif*

haklesoft · 23. Februar 2016

Hallo Carsten,

wenn Du eine Collection befüllst und Deine Suchwörter als Index einfügst, bekommst Du für jede Doublette einen Fehler und kannst darauf reagieren.

Ein Beispiel mit dem Dictionary-Objekt hat Karin geliefert.

DubWay · 23. Februar 2016

Hi Karin und haklesoft

Vielen Dank für eure Beiträge *Smilie funktioniert super.

Nur woran ist meine Methode von oben gescheitert? Wäre gut zu wissen für künftige Fragestellungen mit Arrays *wink.gif*

Gruß Carsten

Beverly · 23. Februar 2016

Hi Carsten,

ich habe deinen Code jetzt nicht getestet, aber ich würde sagen, du musst die innere Schleife verlassen, falls der Begriff gefunden wird - also so:

Code:

For x = 0 To UBound(arrArray())

If arrArray(x) Like Suchbegriff Then

boolVorhanden = True
Exit For

End If

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

Andernfalls läuft der Code ja weiter und würde nur dann zutreffen, wenn der letzte Eintrag übereinstimmt.

Wenn du es über ein Array lösen willst, dann ginge es z.B. so:

Code:

Sub ArrayFuellen()
Dim lngLetzteZeile As Long
Dim lngZaehler As Long
Dim lngZeile As Long
Dim varVorhanden As Variant
Dim arrDaten
ReDim arrDaten(0)
arrDaten(0) = Cells(1, 1)
lngZaehler = 1
lngLetzteZeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For lngZeile = 2 To lngLetzteZeile
varVorhanden = Application.Match(Cells(lngZeile, 1), arrDaten, 0)
If Not IsNumeric(varVorhanden) Then
ReDim Preserve arrDaten(0 To lngZaehler)
arrDaten(lngZaehler) = Cells(lngZeile, 1)
lngZaehler = lngZaehler + 1
End If
Next lngZeile
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

haklesoft · 23. Februar 2016

Hallo Carsten,

hier noch die in #4 angesprochene Variante mit einer Collection: Code:

Sub ColOhneDuplicate()
Dim colDaten As New Collection
Dim varBereich As Variant
Dim lngZaehler As Long
Dim lngLetzteZeile As Long

With ActiveSheet 'Worksheets("Tabelle1")
lngLetzteZeile = .Cells(Rows.Count, 1).End(xlUp).Row
varBereich = .Range(.Cells(1, 1), .Cells(lngLetzteZeile, 1))
End With

On Error Resume Next ' Fehler bei Doppeleintrag übergehen
' Schleife über alle Werte des Bereichs
For lngZaehler = LBound(varBereich) To UBound(varBereich)
colDaten.Add varBereich(lngZaehler, 1), CStr(varBereich(lngZaehler, 1))
Next
On Error GoTo 0

'Gefundene Werte ohne Duplicate ausgeben
Dim i As Long
For i = 1 To colDaten.Count
Debug.Print i, colDaten(i)
Next i
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

DubWay · 23. Februar 2016

Hi Karin, Hi haklesoft

vielen Dank für die insgesamt 3 Möglichkeiten mein Problem zu lösen.
Immer wieder erfreut neue Möglichkeiten kennenzulernen.

Danke *Smilie

Gruß Carsten

Nachtrag:
bei meiner ursprünglichen Methode muss (neben der Ergänzung von Karin) nach der Arraybefüllung die Variable "boolVorhanden" zurück auf False gesetzt werden und nach der Dimensionserhöhung NUR Ubound statt UBound +1

Office: Array befüllen und durchsuchen

Array befüllen und durchsuchen

Array befüllen und durchsuchen

Array befüllen und durchsuchen

Array befüllen und durchsuchen

Array befüllen und durchsuchen - Similar Threads - Array befüllen durchsuchen

VBA Daten in Array durch inputbox befüllen lassen

Listbox mit Array befüllen,bearbeiten &zurückschreiben

Array mit Range aus InputBox befüllen geht nicht

Array so befüllen, dass die gefundene Werte nur einmal vorkommen

ComboBox mit Array befüllen

VBA Excel Array nicht gleich Array?

VBA: Array aus allen Tabellenblättern befüllen