Array aus mehreren Zellen einlesen

[Eizi100]

Hallo zusammen
Und wieder ein Problem, was ich nicht zusammenbringe.
Mit folgendem Code lasse ich mir die Fundstellen am aktiven Blatt "ausgeben"

PHP-Code:

Public Sub Vereinssuche()
Dim rngFind As Range
Dim strFirst As String
Dim strFindArray() As Variant
Dim intCount As Integer

strFindArray = Array("Schalke", "Bayern")

For intCount = 0 To UBound(strFindArray)
  Set rngFind = Range("c2:c20").Find(what:=strFindArray(intCount), LookIn:=xlValues, LookAt:=xlPart)
  If Not rngFind Is Nothing Then
    strFirst = rngFind.Address
    Do
      
      Set rngFind = Range("c2:c20").FindNext(rngFind)
      rngFind.Offset(0, 1) = "Gefunden"
      rngFind.Offset(0, 1).Interior.ColorIndex = 7
    Loop While Not rngFind Is Nothing And rngFind.Address <> strFirst
  End If
  Set rngFind = Nothing
  strFirst = vbNullString
Next
End Sub 


Das funktioniert ganz gut. Ich will es aber schaffen, dass das Array aus einem Tabellenblatt ("Daten") eingelesen wird. Ich habe schon einiges probiert. Der Code liest mir aber immer nur die oberste Zelle ein
Das war mein letzte kläglicher Versuch

PHP-Code:

Public Sub Vereinssuche()
Dim rngFind As Range
Dim strFirst As String
Dim strFindArray() As Variant
Dim intCount As Integer
Dim spieler As Variant
spieler = Sheets("Daten").Range("B1:B5")
strFindArray = Array(spieler)

For intCount = 0 To UBound(strFindArray)
  Set rngFind = Range("c2:c20").Find(what:=strFindArray(intCount), LookIn:=xlValues, LookAt:=xlPart)
  If Not rngFind Is Nothing Then
    strFirst = rngFind.Address
    Do
      
      Set rngFind = Range("c2:c20").FindNext(rngFind)
      rngFind.Offset(0, 1) = "Gefunden"
      rngFind.Offset(0, 1).Interior.ColorIndex = 7
    Loop While Not rngFind Is Nothing And rngFind.Address <> strFirst
  End If
  Set rngFind = Nothing
  strFirst = vbNullString
Next
End Sub 


Ich kämpfe schon (gefühlt seit 2020). Der Hintergrund für dieses Problem hat nichts mit Fussball zu tun, sondern mit meiner Arbeit. Ich will das Array aus der Tabelle holen, da die Daten ca. alle 2 bis 3 Monate geändert werden.
Vielleicht kann mir jemand helfen. Mir wäre schon mit einem Lösungsansatz geholfen 
LG und danke 
Michael

[Elex]

Moin,

mal schauen ob es ohne Datei geht. Was auffällt ist das du für den ersten Fund keine Aktion machst sondern nur das.     strFirst = rngFind.Address

Für die weiteren Funde machst du etwas.
rngFind.Offset(0, 1) = "Gefunden"
rngFind.Offset(0, 1).Interior.ColorIndex = 7

Edit: Da ist noch mehr.
Versuch mal den Code.

Code:

Public Sub Vereinssuche()
Dim rngFind As Range
Dim strFirst As String
Dim strFindArray As Variant
Dim intCount As Integer
Dim spieler As Variant
strFindArray = Sheets("Daten").Range("B1:B5").Value


For intCount = 1 To UBound(strFindArray)
  Set rngFind = Range("c2:c20").Find(what:=strFindArray(intCount, 1), LookIn:=xlValues, LookAt:=xlPart)
  If Not rngFind Is Nothing Then
      strFirst = rngFind.Address
      rngFind.Offset(0, 1) = "Gefunden"
      rngFind.Offset(0, 1).Interior.ColorIndex = 7
    Do
     
      Set rngFind = Range("c2:c20").FindNext(rngFind)
      rngFind.Offset(0, 1) = "Gefunden"
      rngFind.Offset(0, 1).Interior.ColorIndex = 7
    Loop While Not rngFind Is Nothing And rngFind.Address <> strFirst
  End If
  Set rngFind = Nothing
  strFirst = vbNullString
Next
End Sub

Gruß Elex

[Eizi100]

Hi Elex

Und das ohne Datei. Unglaublich. Das funktioniert. Ich habe das jetzt einfach rauskopiert und getestet. Ich werde mir heute Abend die Änderungen genauer ansehen.

Hab nur noch eine Frage. Wie kann ich verhindern, dass mir die leeren Zellen auch als Array bzw Fundstellen ausgegeben werden?
Habs auf die Schnelle ganz einfach gelöst. Ich habe im Blatt "Daten" die leeren Zellen mit einem Punkt gefüllt. Klappt wunderbar

Danke nochmal

LG
Michael

[Elex]

Das könnte man so Lösen.

Code:

Public Sub Vereinssuche()
Dim rngFind As Range
Dim strFirst As String
Dim strFindArray As Variant
Dim intCount As Integer
strFindArray = Sheets("Daten").Range("B1:B5").Value

For intCount = 1 To UBound(strFindArray)
If strFindArray(intCount, 1) <> "" Then
  Set rngFind = Range("c1:c20").Find(what:=strFindArray(intCount, 1), LookIn:=xlValues, LookAt:=xlPart)
  If Not rngFind Is Nothing Then
      strFirst = rngFind.Address
      rngFind.Offset(0, 1) = "Gefunden"
      rngFind.Offset(0, 1).Interior.ColorIndex = 7
    Do
    
      Set rngFind = Range("c1:c20").FindNext(rngFind)
      rngFind.Offset(0, 1) = "Gefunden"
      rngFind.Offset(0, 1).Interior.ColorIndex = 7
    Loop While Not rngFind Is Nothing And rngFind.Address <> strFirst
  End If
  Set rngFind = Nothing
  strFirst = vbNullString
End If
Next
End Sub

Etwas eleganter wäre es nicht mit festen Range Bereiche zu arbeiten, sondern sie automatisch zu ermitteln. Das geht aber nur mit fortlaufenden Listen wo die Lücken/Leerzellen nicht zwischen drin sind. 

Gruß Elex

[Eizi100]

Danke nochmal

Das funktioniert sowas von perfekt. vbNullString kannte ich gar nicht.


Wegen der Leerzeichen. Ich kopiere die Daten von einer WordListe ins Blatt. Darum habe ich auch diese verfluchten leeren Zellen.

Die Datei ist für einen interne Wagenliste bei der Bahn. 
Ein Beispiel
Wagen1 mit der Ordnungsnummer 1 fährt von München nach Dortmund, wird dort auf Zug BlaBla an 3. Stelle gehängt. Fährt dann von Dortmund nach Hamburg wird dort wieder umgehängt an Zug BlaBla an 10. Stelle usw. Darum brauche ich das Array (Die Ordnungsnummern bleiben immer gleich, nur die Reihungen und Züge ändern sich. Und es geht nicht um einen Waggon , sondern um mehrere.

Aus diesem Grund habe ich das Beispiel mit den Fussballspieler

Danke nochmal
Das ist sowas von perfekt

LG
Michael

[LCohen]

Hoffentlich nicht sicherheitskritisch, so eine Wagennummer.

[Eizi100]

Nö 
Wenn das sicherheitsrelevant wäre, würde ich das lassen.

Wir haben eigene Systeme dafür. Die ExcelDatei ist nur zum kontrollieren bzw als Vereinfachung zum eintragen
LG
Michael