103 Aufrufe
Gefragt in Tabellenkalkulation von
Hallo M.O

du hast mir mal dieses Makro geschrieben,
es sucht nach Zahlen und fügt sie in eine neue Tabelle.
Das Makro läuft einwandfrei.

Sub Arraysuchen()

Dim wksBlatt1 As Worksheet
Dim wksBlatt2 As Worksheet
Dim wksBlatt3 As Worksheet
Dim lngLetzte As Long
Dim lngLetzte3 As Long
Dim lngSpalte As Long
Dim lngSpalteL As Long
Dim varSuchen As Variant
Dim varSpalte As Variant
Dim lngZaehler As Long
Dim s As Long
Dim a As Long
Dim e As Long
Dim lngAnfang As Long
Dim lngEnde As Long
Dim lngFarbe As Long
Dim lngZeile As Long
Dim lngEinleseS As Long
Dim lngDurchlauf As Long
Dim lngd As Long

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Arbeitsblätter festlegen
Set wksBlatt1 = ThisWorkbook.Worksheets("Archiv-Zahlen") 'Tabelle, die durchsucht werden soll
Set wksBlatt2 = ThisWorkbook.Worksheets("Such->Zahlen") 'Tabelle mit den zu suchenden Zahlen
Set wksBlatt3 = ThisWorkbook.Worksheets("Gefundene Zahlen") 'Tabelle in die die Suchergebnisse einfügt werden

'Suchzahlen aus Arbeitsblatt Suchartikel in Array einlesen
'dazu die letzte Zeile im Arbeitsblatt in Spalte A ermitteln
With wksBlatt2
lngLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
'nun ab A1 die Daten in das Sucharray einlesen
varSuchen = .Range(.Cells(1, 1), .Cells(lngLetzte, 1))
End With

'in Zieltabelle für Suchergebnisse ggf. vorhandene Daten löschen
wksBlatt3.Cells.Clear

'Im Suchblatt letzte Spalte ermitteln
lngSpalteL = wksBlatt1.Cells(1, Columns.Count).End(xlToLeft).Column

'Anzahl der Spalten festlegen, die pro Durchlauf eingelesen werden sollen
lngEinleseS = 1

'Anzahl der Durchläufe ermitteln
'Ganzzahl der Durchläufe ermitteln
lngDurchlauf = Int(lngSpalteL / lngEinleseS)
'Prüfen, ob Durchlauf ggf. um 1 erhöht werden muss
If lngSpalteL Mod lngEinleseS > 0 Then lngDurchlauf = lngDurchlauf + 1

'letzte Zeile ermitteln
lngLetzte = wksBlatt1.Cells.SpecialCells(xlCellTypeLastCell).Row

'Schleife, um alle Spalten im Suchblatt zu durchlaufen
For lngd = 0 To lngDurchlauf - 1

With wksBlatt1
'Spalten in Array einlesen
varSpalte = .Range(.Cells(1, 1 + lngd * lngEinleseS), .Cells(lngLetzte, lngEinleseS + lngEinleseS * lngd))
End With

'Vergleich
For lngSpalte = LBound(varSpalte, 2) To UBound(varSpalte, 2)
'Statusmeldung
Application.StatusBar = "Spalte " & lngSpalte + lngd * lngEinleseS & " von " & lngSpalteL & " wird durchsucht "

For a = LBound(varSpalte, 1) To UBound(varSpalte, 1)
'Zaehler auf Null setzen
lngZaehler = 0
For s = LBound(varSuchen, 1) To UBound(varSuchen, 1)
'Prüfen, ob zu vergleichendes Element im Array varSpalte existiert
If a + s - 1 <= UBound(varSpalte, 1) Then
'falls ja, dann vergleichen
If varSpalte(a + s - 1, lngSpalte) = varSuchen(s, 1) Or varSuchen(s, 1) = "*" Then
lngZaehler = lngZaehler + 1
Else
Exit For
End If
End If
Next s

'Falls Übereinstimmung,
If lngZaehler = UBound(varSuchen, 1) Then

'dann Anfang und Ende des einzufügenden Bereichs festlegen
lngAnfang = a - 5
lngEnde = a + UBound(varSuchen, 1) + 4
'Anfang und Ende prüfen, ob diese im zulässigen Bereich liegen
If lngAnfang < 1 Then lngAnfang = 1
If lngEnde > UBound(varSpalte, 1) Then lngEnde = UBound(varSpalte, 1)
'Zeile für das Einfärben der gefundenen Übereinstimmungen ermitteln
lngFarbe = a - lngAnfang

'letzte Zeile in Einfügespalte = Suchspalte ermitteln
lngLetzte3 = wksBlatt3.Cells(Rows.Count, lngSpalte + lngEinleseS * lngd).End(xlUp).Row + 2
'Einfügezeile ggf. korrigieren
If lngLetzte3 = 3 Then lngLetzte3 = 1
'Inhalte einfügen
With wksBlatt3
'Zähler für Einfügezeile auf Null setzen
lngZeile = 0
For e = lngAnfang To lngEnde
.Cells(lngLetzte3 + lngZeile, lngSpalte + lngEinleseS * lngd) = varSpalte(e, 1)
lngZeile = lngZeile + 1
Next e
End With

'Suchzahlen in gefundener Reihe einfärben
With wksBlatt3
.Range(.Cells(lngLetzte3 + lngFarbe, lngSpalte + lngEinleseS * lngd), .Cells(lngLetzte3 + lngFarbe + UBound(varSuchen, 1) - 1, lngSpalte + lngEinleseS * lngd)).Interior.ColorIndex = 28
End With
End If

Next a

Next lngSpalte
Next lngd

'Auf Blatt 3 mit den gefundenen Daten wechseln
With wksBlatt3
.Activate
.Range("A1").Select
End With


'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Nun meine Frage gebe es eine Möglichkeit mehrere Zahlen gleichzeitig zu suchen?

Also z.b anstatt
45
8
18

soll er

45
8,9,10
17,18

suchen in jeder Möglichen Konstellation aber richtigen Reihenfolge.
Immo ist es so, das ich das seperat suchen muss.

K.A ob das so machbar wäre.
Vielleicht mit Variablen die man den Zahlen vorher zuweist oder so.

Über eine Antwort würde ich mich freuen wie auch immer die aussieht.

lg
Ellea19

2 Antworten

0 Punkte
Beantwortet von m-o Profi (11.5k Punkte)
Hallo Ellea,

was meinst du genau mit
suchen in jeder Möglichen Konstellation aber richtigen Reihenfolge.


Soll er bei deinem Beispiel
45
8,9,10
17,18

also u.a.
45 - 8 - 17
45 - 9 - 17
45 - 9 - 18
45 -10 - 17

finden?

Das ist grundsätzlich machbar.

Gruß

M.O.
0 Punkte
Beantwortet von
Hi M.O

ja genau so meinte ich das, also jede Mögliche Zahlenkombination

45 - 8 - 17
45 - 8 - 18
45 - 9 - 17
45 - 9 - 18
45 -10 - 17
45 -10 - 18


Lg
Ellea
...