387 Aufrufe
Gefragt in Tabellenkalkulation von letty19 Einsteiger_in (88 Punkte)
Hallo M.O

du hattest mir mal bei einem Makro geholfen und eins für mich geschrieben.

Sucht Zahlen aus eine Tabelle vergleicht und kopiert die Übereinstimmenden Zahlen in eine neue Tabelle.Ich bräuchte bitte eine Anpassung des Makros.

Derzeit läuft es so das aus Spalte A die Zahlen im Archiv gesucht werden, da ich aber mehr Daten

zu Suchen habe kannst du das vielleicht so Anpassen das wenn er fertig ist dann aus Spalte B,C,D, usw

gesucht wird.Also in allen Spalten wo neue Zahlen stehen

Alles Ergebnisse sollen dann im neuen Arbeitsblatt angezeigt werden und nicht überschrieben werden

So sieht derzeit dein Makro aus

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")   'Tabelle, die durchsucht werden soll
Set wksBlatt2 = ThisWorkbook.Worksheets("Such->Zahlen")      'Tabelle mit den zu suchenden Zahlen
Set wksBlatt3 = ThisWorkbook.Worksheets("G")         '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 "
  DoEvents
  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) + 5
    '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

Wäre echt toll wenn du mir das nochmals anpassen könntest

11 Antworten

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)

Hallo Letty,

ich erinnere mich dunkel wink.

zu Suchen habe kannst du das vielleicht so Anpassen das wenn er fertig ist dann aus Spalte B,C,D, usw

Ich nehme an, du meinst damit das Tabellenblatt in dem die Suchzahlen stehen. Du willst also mehrere Zahlenkombinationen suchen. Und die Ergebnisse sollen alle in einem Arbeitsblatt angezeigt werden?

Gruß

M.O.

0 Punkte
Beantwortet von

https://supportnet.de/forum/?qa=blob&qa_blobid=2429201660555278911

Hallo M.O danke das du antwortest

Ja genau er soll wenn Tabella A fertig ist mit Tabelle B weitermachen unsw

Hab mich mal versucht in deinem Makro habs angehängt da siehst du sofort was ich meine

Das ist natürlich "russisch" aber es funktioniert halbwegs.

Wenn es geht kannst du das besser anpassen

Bitte

lg

Letty

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)

Hallo Letty,

du kannst jetzt in der Tabelle mit den Suchzahlen beliebig viele Spalten füllen. Die Suchzahlen müssen immer in der ersten Zeile beginnen.

Hier mal das überarbeitete Makro:

Sub Arraysuchen_neu()

Dim wksBlatt1 As Worksheet
Dim wksBlatt2 As Worksheet
Dim wksBlatt3 As Worksheet
Dim varSuchen As Variant
Dim varArchiv As Variant
Dim s As Long
Dim z As Long
Dim lngSpalte As Long
Dim lngZeile As Long
Dim lngLZahl As Long
Dim lngZeileAnfang As Long
Dim lngZeileEnde As Long
Dim lngZeileEinf As Long
Dim lngAnzahl As Long
Dim lngZaehler As Long
Dim lngLSpalte As Long
Dim lngEZeile As Long
Dim lngZZaehler As Long
Dim lngFarbe 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
With wksBlatt2
   varSuchen = .Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
End With

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

'Daten aus Suchblatt in Array einlesen
With wksBlatt1
   varArchiv = .Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
End With

'Suchspalten im Array durchlaufen
For s = LBound(varSuchen, 2) To UBound(varSuchen, 2)
   lngLZahl = 0   'Variable für die Position der letzten Suchzahl im Suchfeld
   'Anzahl der Suchzahlen in Spalte ermitteln
   For z = 1 To UBound(varSuchen, 1)
     If varSuchen(z, s) <> 0 Then lngLZahl = lngLZahl + 1
   Next z
   
  'Schleife, um alle Spalten im Archiv zu durchlaufen
  For lngSpalte = LBound(varArchiv, 2) To UBound(varArchiv, 2)
    'Statusmeldung
    Application.StatusBar = "Spalte " & lngSpalte & " von " & UBound(varArchiv, 2) & " wird durchsucht "
    'die einzelnen Spalten zeilenweise durchlaufen
    For lngZeile = LBound(varArchiv, 1) To UBound(varArchiv, 1)
       'Variable für Zähler zurücksetzen
       lngZaehler = 0
       'Array mit Suchzahlen durchlaufen
       For z = LBound(varSuchen, 1) To lngLZahl
         'prüfen, ob nächste Zahl noch in Zahlenreihe im Archiv existiert
         If lngZeile + z - 1 <= UBound(varArchiv, 1) Then
            If varArchiv(lngZeile + z - 1, lngSpalte) = varSuchen(z, s) Then
                'falls Übereinstimmung, dann Variable um 1 erhöhen
                 lngZaehler = lngZaehler + 1
              Else
                 'ansonsten Schleife verlassen
                 Exit For
            End If
         End If
       Next z
       'prüfen ob Zahlenreihe gefunden
       If lngZaehler = lngLZahl Then
         lngZeileAnfang = lngZeile - 5
         lngZeileEnde = lngZeile + lngLZahl + 4
         'Anfang und Ende prüfen, ob diese im zulässigen Bereich liegen
         If lngZeileAnfang < 1 Then lngZeileAnfang = 1
         If lngZeileEnde > UBound(varArchiv, 1) Then lngZeileEnde = UBound(varArchiv, 1)
         'Zeile für das Einfärben der gefundenen Übereinstimmungen ermitteln
         lngFarbe = lngZeile - lngZeileAnfang
         'letzte Zeile in Einfügespalte = Suchspalte ermitteln und eine Zeile Abstand lassen
         With wksBlatt3
              lngZeileEinf = .Cells(Rows.Count, lngSpalte).End(xlUp).Row + 2
              'Einfügezeile ggf. korrigieren, wenn erste Einfügezeile 1 ist
              If lngZeileEinf = 3 Then lngZeileEinf = 1
              'Variable für Zeilenzähler zurücksetzen
              lngZZaehler = 0
              'Daten einfügen
              For lngEZeile = lngZeileAnfang To lngZeileEnde
                .Cells(lngZeileEinf + lngZZaehler, lngSpalte) = varArchiv(lngEZeile, lngSpalte)
                lngZZaehler = lngZZaehler + 1
              Next lngEZeile
              'Suchzahlen einfärben
              .Range(.Cells(lngZeileEinf + lngFarbe + 1, lngSpalte), .Cells(lngZeileEinf + lngFarbe + lngLZahl, lngSpalte)).Interior.ColorIndex = 28
              'auf Ausgabeblatt wechseln
              .Activate
              .Range("A1").Select
         End With
       End If
    Next lngZeile
 Next lngSpalte
Next s
        
Application.StatusBar = False

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Schau mal, ob das so funktioniert, wie du dir das vorstellst.

Gruß

M.O.

0 Punkte
Beantwortet von letty19 Einsteiger_in (88 Punkte)
Hi M.O

läuft super genau so ist das Perfekt.

Aber 2 Sachen hätte Bitte ich noch. Kannst du mir die Statusbar wieder einbauen damit ich sehen kann

welche Spalte er im Suchblatt gerade durchläuft.

Hab viele Spalten zu durchsuchen und damit wäre mir Zeitlich sehr geholfen

und das 2. wäre bitte alle leeren Zeilen löschen wenn er fertig ist

Sodas ich die gefundenen Zahlen nebeneinander in der Tabelle habe

Ansonsten passt alles !!
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)

Hallo Letty,

hiermit werden die Ergebnisse jeweils in einer neuen Spalte angezeigt, ohne Leerspalten:

Sub Arraysuchen_neu()

Dim wksBlatt1 As Worksheet
Dim wksBlatt2 As Worksheet
Dim wksBlatt3 As Worksheet
Dim varSuchen As Variant
Dim varArchiv As Variant
Dim s As Long
Dim z As Long
Dim lngSpalte As Long
Dim lngZeile As Long
Dim lngLZahl As Long
Dim lngZeileAnfang As Long
Dim lngZeileEnde As Long
Dim lngZeileEinf As Long
Dim lngAnzahl As Long
Dim lngZaehler As Long
Dim lngLSpalte As Long
Dim lngEZeile As Long
Dim lngZZaehler As Long
Dim lngFarbe As Long
Dim lngEinfSpalte As Long

'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
With wksBlatt2
   varSuchen = .Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
End With

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

'Daten aus Suchblatt in Array einlesen
With wksBlatt1
   varArchiv = .Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
End With

'Suchspalten im Array durchlaufen
For s = LBound(varSuchen, 2) To UBound(varSuchen, 2)
   lngLZahl = 0   'Variable für die Position der letzten Suchzahl im Suchfeld
   'Anzahl der Suchzahlen in Spalte ermitteln
   For z = 1 To UBound(varSuchen, 1)
     If varSuchen(z, s) <> 0 Then lngLZahl = lngLZahl + 1
   Next z
   
  'Schleife, um alle Spalten im Archiv zu durchlaufen
  For lngSpalte = LBound(varArchiv, 2) To UBound(varArchiv, 2)
    'Statusmeldung
    Application.StatusBar = "Spalte " & lngSpalte & " von " & UBound(varArchiv, 2) & " wird durchsucht "
    'die einzelnen Spalten zeilenweise durchlaufen
    For lngZeile = LBound(varArchiv, 1) To UBound(varArchiv, 1)
       'Variable für Zähler zurücksetzen
       lngZaehler = 0
       'Array mit Suchzahlen durchlaufen
       For z = LBound(varSuchen, 1) To lngLZahl
         'prüfen, ob nächste Zahl noch in Zahlenreihe im Archiv existiert
         If lngZeile + z - 1 <= UBound(varArchiv, 1) Then
            If varArchiv(lngZeile + z - 1, lngSpalte) = varSuchen(z, s) Then
                'falls Übereinstimmung, dann Variable um 1 erhöhen
                 lngZaehler = lngZaehler + 1
              Else
                 'ansonsten Schleife verlassen
                 Exit For
            End If
         End If
       Next z
       'prüfen ob Zahlenreihe gefunden
       If lngZaehler = lngLZahl Then
         lngZeileAnfang = lngZeile - 5
         lngZeileEnde = lngZeile + lngLZahl + 4
         'Anfang und Ende prüfen, ob diese im zulässigen Bereich liegen
         If lngZeileAnfang < 1 Then lngZeileAnfang = 1
         If lngZeileEnde > UBound(varArchiv, 1) Then lngZeileEnde = UBound(varArchiv, 1)
         'Zeile für das Einfärben der gefundenen Übereinstimmungen ermitteln
         lngFarbe = lngZeile - lngZeileAnfang
         'Zähler für Einfügespalte um 1 erhöhen
         lngEinfSpalte = lngEinfSpalte + 1
         'letzte Zeile in Einfügespalte ermitteln und eine Zeile Abstand lassen
         With wksBlatt3
              lngZeileEinf = .Cells(Rows.Count, lngEinfSpalte).End(xlUp).Row + 2
              'Einfügezeile ggf. korrigieren, wenn erste Einfügezeile 1 ist
              If lngZeileEinf = 3 Then lngZeileEinf = 1
              'Variable für Zeilenzähler zurücksetzen
              lngZZaehler = 0
              'Daten einfügen
              For lngEZeile = lngZeileAnfang To lngZeileEnde
                .Cells(lngZeileEinf + lngZZaehler, lngEinfSpalte) = varArchiv(lngEZeile, lngSpalte)
                lngZZaehler = lngZZaehler + 1
              Next lngEZeile
              'Suchzahlen einfärben
              .Range(.Cells(lngZeileEinf + lngFarbe, lngEinfSpalte), .Cells(lngZeileEinf + lngFarbe + lngLZahl - 1, lngEinfSpalte)).Interior.ColorIndex = 28
              'auf Ausgabeblatt wechseln
              .Activate
              .Range("A1").Select
         End With
       End If
    Next lngZeile
 Next lngSpalte
Next s
        
Application.StatusBar = False

End Sub

Schau mal, ob das so funktioniert, wie du willst. Der Statusbar sollte auch wieder zu sehen sein.

Gruß

M.O.

0 Punkte
Beantwortet von letty19 Einsteiger_in (88 Punkte)

Hi M.O.

Ist genau so wie erwartet paßt(fast)

Nur ist mir etwas aufgefallen worauf ich mir keinen Reim machen kann.

In den Suchzahelen ist eine Zahlenreihe 17-0-10-21 und nach dem Durchlauf findet er 17-0-10-11

aber diese Kombination wird nicht gesucht ist aber im Archiv enthalten. Verstehst du das???

Woran kann das liegen habs mal hochgeladen und eingefärbt das erkennst du gleich

https://supportnet.de/forum/?qa=blob&qa_blobid=2252978344494619990

Irgendwie sieht er die 1 in der letzten Zahl und zeigt das Ergebniss dann an

Sehr komisch aber der Rest ist super

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Bearbeitet von m-o

Hallo Letty,

ja, ich verstehe das. Ich habe eine Prüfung eingebaut, dass nur Suchzahlen größer Null akzeptiert werden.

Ändere den Codeteil

'Suchspalten im Array durchlaufen
For s = LBound(varSuchen, 2) To UBound(varSuchen, 2)
   lngLZahl = 0   'Variable für die Position der letzten Suchzahl im Suchfeld
   'Anzahl der Suchzahlen in Spalte ermitteln
   For z = 1 To UBound(varSuchen, 1)
     If varSuchen(z, s) <> 0 Then lngLZahl = lngLZahl + 1
   Next z

in

'Suchspalten im Array durchlaufen
For s = LBound(varSuchen, 2) To UBound(varSuchen, 2)
   lngLZahl = 0   'Variable für die Position der letzten Suchzahl im Suchfeld
   'Anzahl der Suchzahlen in Spalte ermitteln
   For z = 1 To UBound(varSuchen, 1)
     If varSuchen(z, s) <> "" Then lngLZahl = lngLZahl + 1
   Next z

Probiere jetzt, ob er auch die Zahlenkolonnen mit Null findet.

Gruß

M.O.

0 Punkte
Beantwortet von

Hi M.O

konnte das jetzt ein wenig Testen.

Das mit der 0 funktioniert jetzt aber 2 Sachen

.https://supportnet.de/forum/?qa=blob&qa_blobid=3432736089775874832

im Bild sieht man er durchläuft alle Spalten im Archiv aber er sollte mir  im Suchblatt zeigen welche Spalte gerade gescannt wird.zb Spalte 1 von 12 oder so

Und das 2. manchmal bekomm ich einen Anwendungsfehler durchläuft nicht alle Spalten

bleibt dann im Debug-Modus bei der Meldung stehen

.Range(.Cells(lngZeileEinf + lngFarbe, lngEinfSpalte), .Cells(lngZeileEinf + lngFarbe + lngLZahl - 1, lngEinfSpalte)).Interior.ColorIndex = 28

Aber ansonsten passt das schon !!

0 Punkte
Beantwortet von letty19 Einsteiger_in (88 Punkte)
Hi M.O

Also der Anwendungsfehler kommt dadurch wenn man zuerst mehr Spalten und dann weniger Spalten durchsucht also ein "Anwendungsfehler" meinerseits.

Und das mit der Statusbar ist auch nicht schlimm also somit passt das schon.

Danke fürs Makro hast mir sehr geholfen(wiedereinmal)
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)

Hallo Letty,

das mit der Statusmeldung ist kein Problem.

Ändere die entsprechende Zeile im Code wie folgt:

'Statusmeldung
    Application.StatusBar = "Suchreihe " & s & " von " & UBound(varSuchen, 2) & ": Spalte " & lngSpalte & " von " & UBound(varArchiv, 2) & " wird durchsucht "

Das mit dem Anwendungsfehler kann ich nicht ganz nachvollziehen. Der Fehler passiert beim dann beim Einfärben der gefundenen Zellen. Bei einem Fehler bleibt wird das Makro beendet und daher werden natürlich auch nicht alle Spalten durchsucht.

Gruß

M.O.

...