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
Hi M.O

Danke das mit der Statusbar ist jetzt auch gut

Somit ist das Makro so wie ich es gerne wollte.

Vielen Dank

lg Letty
...