Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1804to1808
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

Array ReDim (Preserve?)

Array ReDim (Preserve?)
17.01.2021 15:17:43
Jerry
Liebe Community,
Ich habe eine Problem mit Arrays.
Zeile Spalte E
6 Otto
7 Maria
8 Maria
9 Franz
10 Otto
11 Otto
12 Otto
13 Franz
14 Franz
Otto Maria Franz
Ich habe eine Liste mit 3 Namen und will auslesen, in welchen Zeilen der jeweilige Name steht.
Also baue ich 3 Arrays auf, jedes für 1 Namen, hier ist die Dimensionierung 1 To 3,
Im Gegensatz zu dem begrenzten Beispiel oben ist die Liste aber viel länger und ich weiss nicht, wie ich
die Dimensionierung für eine vorher unbestimmte Anzahl von Zeilen mache, in der der jeweilige Name vorkommt.
Hier mein (schlechter Code), der nicht funktioniert:
Public Sub probe()
Dim arr()
ReDim arr(1 To 3, 1 To 1)
Dim mm(3) As Integer
Dim Strg As String
Dim such(3) As String
mm(1) = 0
mm(2) = 0
mm(3) = 0
a = Range("E6").Address
b = Range("E6").End(xlDown).Address
Set blatt = Range(a, b)
For Each k In blatt
suchStrg = LCase(k.Value)
Strg = Replace(suchStrg, " ", "")
For p = 1 To 3
such(1) = LCase("Otto")
such(2) = LCase("Maria")
such(3) = LCase("Franz")
If InStr(Strg, such(p)) > 0 Then
mm(p) = mm(p) + 1
ReDim Preserve arr(p, 1 To mm(p))
arr(p, mm(p)) = k.Row
GoTo raus
End If
Next p
raus:
Next k
'Auslesen der Arrays
For i = 1 To 3
If i = 1 Then sp = "E"
If i = 2 Then sp = "F"
If i = 3 Then sp = "G"
rr = 0
For q = 1 To mm(i)
Range(sp & 18).Offset(rr, 0).Value = arr(i, mm(q))
rr = rr + 1
Next q
Next i
'ENDE Auslesen
l = 0
End Sub

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Array ReDim (Preserve?)
17.01.2021 16:55:48
GraFri
Hallo
Vielleicht hilft dir das weiter:
Option Explicit
Public Sub Probe()
Dim myArr() As Variant
Dim such(3) As String
Dim iRow As Long
' Suchbegriffe
such(1) = "Otto": such(2) = "Maria": such(3) = "Franz"
' eindimensionales Array beginnend mit E6 bis zum Ende einlesen
With ThisWorkbook.Worksheets("Tabelle1")
myArr = Application.Transpose(.Range(.[E6], .Cells(Rows.Count, "E").End(xlUp)))
End With
' Zeigt das 1. Vorkommen des Suchbegriffs
iRow = Application.Match(such(1), myArr, 0) + 5 ' Da ab 6. Zeile
If Err > 0 Then
MsgBox "Nicht gefunden"
Else
MsgBox "An " & iRow & " .Stelle gefunden"
End If
End Sub
mfg, GraFri
Anzeige
AW: Array ReDim (Preserve?)
17.01.2021 17:57:45
GraFri
Hallo
Nachstehender Code durchsucht das Array 'myArr' und packt die Zeilennummern der Funde in das Array 'woGefunden'. Danach wird eine Liste der Funde ausgegeben.
Option Explicit
Public Sub Probe()
Dim myArr() As Variant
Dim such(3) As String
Dim woGefunden() As Long
Dim n As Long, zähler As Long
' Suchbegriffe
such(1) = "Otto": such(2) = "Maria": such(3) = "Franz"
' eindimensionales Array beginnend mit E6 bis zum Ende einlesen
With ThisWorkbook.Worksheets("Tabelle1")
myArr = Application.Transpose(.Range(.[E6], .Cells(Rows.Count, "E").End(xlUp)))
End With
' neu dimensionieren mit maximalen Fundstellen
ReDim woGefunden(1 To UBound(myArr))
' Suche im Array
zähler = 1
For n = 1 To UBound(myArr)
If myArr(n) = such(1) Then woGefunden(zähler) = n + 5: zähler = zähler + 1
Next n
' Kontrolle, ob was gefunden wurde
If zähler = 1 Then  ' kein Fund
MsgBox such(1) & " nicht gefunden"
Exit Sub
End If
' Array woGefunden verkleinern
ReDim Preserve woGefunden(1 To zähler - 1)
' Zeilennummern der Fundstellen in Spalte ab F6 ausgeben
With ThisWorkbook.Worksheets("Tabelle1").Cells(6, 6)
.Resize(UBound(woGefunden) - LBound(woGefunden) + 1, 1) = Application.Transpose(woGefunden)
End With
End Sub
mfg GraFri
Anzeige
AW: Array ReDim (Preserve?)
18.01.2021 08:43:22
Jerry
Vielen Dank GraFri,
Das sieht hervorragend aus, werde mich g,leich damit beschäftigen.
LG
Jerry

44 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige