Hi Leute
Hab hier ein Makro vom Archiv das nach Zahlen sucht.
geschrieben von M.O
Sub Arraysuchen0()
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("Tab1") 'Tabelle, die durchsucht werden soll
Set wksBlatt2 = ThisWorkbook.Worksheets("Tab2") 'Tabelle mit den zu suchenden Zahlen
Set wksBlatt3 = ThisWorkbook.Worksheets("Tab3") '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) 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 - 3
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
Application.StatusBar = False
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
Das Makro sucht nach angebenen Zahlen in eingegebener Reihenfolge und kopiert diese in neue Tabelle z.B
17
99
4
75
3
könnte man vielleicht eine Variable eingeben die für alle Zahlen gilt die in dieser Reihenfolge so stehen
also
z.B so
17
99
a= Alle Zahlen die in dieser Reihenfolge so vorkommen
75
3
gefunden wird dann
17 17
99 99
11 oder 83
75 75
3 3
Habe versucht das Feld leer zulassen aber dann findet er nur die Zahl 0.
Mein Archiv beinhaltet nur Zahlen von 1-175
Vielleicht kennt sich jemand damit aus
