VBA Wenn kein Treffer, dann mit nächster Tabelle weitermachen

[Stoffo]

Hallo zusammen,

ich habe ein Makro, welches über mehrere Arbeitsblätter Tabellenspalten (mal eine, mal mehrere) auf einen bestimmten Eintrag (= Suchtext) prüft und mir die "Trefferzeilen" in einer anderen Datei einfügt. Solange in allen Tabellen mindestens ein Treffer vorliegt funktioniert auch alles soweit. Jetzt ist es jedoch so, dass teilweise keine Treffer in einzelnen Tabellen gefunden werden, was dazu führt, dass das gesamte Makro mir einen Indexfehler auswirft und abbricht.
Daher meine Frage, wie ich folgenden Abschnitt ändern müsste damit Tabellen ohne Treffer trotzdem geprüft, jedoch im Falle keines Treffers das Makro fortgesetzt wird:

Code:

   With Application.Workbooks.Open("Arbeitsmappe 1")
      Set rQu = .Worksheets("eine zu prüfende Tabelle in AM 1").Range("A2").CurrentRegion
    With Application.Workbooks.Open("Arbeitsmappe 2")
      Set rZi = .Worksheets("Arbeitsblatt in Mappe 2 in das die Daten sollen").Range("A47")
      Set ws = .Worksheets("Arbeitsblatt in Mappe 2 in das die Daten sollen")
   End With
   End With
   
       
   Daten = rQu
   For iZe = 1 To UBound(Daten, 1)
      For iSp = 54 To 58
         If Daten(iZe, iSp) = Suchtext Then cZproe.Add iZe: Exit For
      Next iSp
   Next iZe
   ReDim Kopie(1 To cZproe.Count, 1 To 58)
   For iZe = 1 To UBound(Kopie, 1)
      For iSp = 1 To UBound(Kopie, 2)
         Kopie(iZe, iSp) = Daten(cZproe(iZe), iSp)
      Next iSp
   Next iZe
   rZi.Resize(UBound(Kopie, 1), UBound(Kopie, 2)) = Kopie       

Alle Tabellen die geprüft werden prüfe ich nach obigem Schema, lediglich mit unterschiedlichen Bereichen. Ich hoffe mein Problem ist verständlich und bin gespannt auf eure Vorschläge. Als Laie in VBA komme ich einfach nicht weiter.

[Stoffo]

Niemand eine Idee?

[HKindler]

Hi,

ist halt schwer hier nur Aufgrund eines Code-Fragments etwas Definitives zu sagen. Was ist z.B. cZproe für eine Variable? Könnte die am Ende der ersten gezeigten Schleife eventuell noch keine Elemente haben? Falls ja, dann solltest du das überprüfen und entsprechende Gegenmaßnahmen (z.B. das Übersprungen des ReDim und der folgenden Schleife) einleiten.

[NobX]

Hallo,

habe folgendes im Netz gefunden:

Code:

On Error Resume Next

".......ist die „primitivste“ Form der Fehlerbehandlung: Fehlerhafte Codezeilen, die nach dieser Anweisung auftauchen, werden einfach ignoriert, der Code wird in der nächsten Zeile nach dem Fehler weiter abgearbeitet."

Gehört vor die For - Next Schleife.

Grüße

NobX

[snb]

Code:

Sub M_snb()
  With GetObject("G:\OF\Beispiel.xlsx")
    sn = Array(.Sheets(1).CurrentRegion.Value, "")
    .Close 0
  End With
  With GetObject("G:\OF\Beispiel2.xlsx")
    sn(1) = .Sheets(1).CurrentRegion.value
    .Close 0
  End With

  For Each it In sn
    For j = 1 To UBound(it)
      For jj = 54 To 58
        If it(j, jj) = "x" Then Exit For
      Next
      If j <= UBound(it) Then c00 = c00 & "_" & it(j, jj)
    Next
  Next
   
  MsgBox c00
End Sub

[Stoffo]

Hallo,

zunächst vielen Dank für eure Antworten.

@HKindler:
Anbei die Deklarationen

Code:

Dim rQu As Range, rZi As Range
Dim ws As Worksheet
Dim Daten, Kopie
Dim iSp As Long, iZe As Long
Dim Suchtext As String
Dim cZproe As New Collection

Ja, die Schleife hat am Ende kein Element, da in einer der geprüften Tabellen (bzw. in diesem Beispiel den Spalten 54 bis 58) der Suchtext nicht zwangsläufig auftaucht. Hierfür benötige ich daher tatsächlich Gegenmaßnahmen (If Nothing Then ???) habe aber keine Ahnung, wie dies in dem Code angepasst werden müsste.

@Nobx:
Die "Lösung" habe ich auch schon gefunden, da ich aber einen Errorhandler im Makro habe um Fehleingaben abzufangen sehe ich von dieser Lösung ab. Darüber hinaus habe ich Sorge, dass ein Aushebeln von Fehlermeldungen zu versteckten Problemen führt (wie gesagt bin VBA Laie).

@snb:
Vielen Dank für deinen Vorschlag, leider kriege ich diesen jedoch nicht umgesetzt. Könntest du ggf. dein Beispiel mit meinen Variablen anpassen?

[snb]

Nicht ohne deine Beispieldatei.

[Stoffo]

Hallo,

anbei die Beispieldateien. Daten sollen in Mappe 1 gesucht und in Mappe 2 an den entsprechenden Stellen eingefügt werden. Suchbegriff ist identisch in allen Arbeitsblättern, jedoch in unterschiedlichen Spalten. Bei einem Treffer soll stets die gesamte Zeile bis zum Ende der Tabelle kopiert und eingefügt werden. Sofern in allen Arbeitsblättern der Suchbegriff auftaucht funktioniert mein Makro wie gesagt bereits, wenn jedoch in einem Arbeitsblatt (bspw. in Tabelle 3) kein Treffer zu finden ist klappt es noch nicht.

[derHoepp]

Hallo,

Divide and Conquer. Ich würde eine einzelne Function erstellen, die die angegebenen Spalten des Quellbereichs durchsucht und alle Fundstellen samt ihrer Zeile zurückgibt. Dabei greife ich natürlich auf die eingebaute Range-Methode .Find() zurück. da sparst du dir das Arbeiten im Array mit inneren und äußeren Schleifen.

Das aufrufende Programm kann die dann weiterverarbeiten (im Beispiel durch kopieren). Die Suchspalten werden als eindimensionales Array mit den Spaltennummern übergeben. 

Ich habe es an deinen Beispieldateien jedoch noch nicht getestet.

Code:

Option Explicit

Sub testen()
    Dim tmp As Range
    Set tmp = GetRowsWithMultiColumnMatch(Me.Cells(1).CurrentRegion, Array(2, 4), "x")
    If Not tmp Is Nothing Then
        tmp.Copy Tabelle2.Cells(1, 1)
    End If
End Sub

Function GetRowsWithMultiColumnMatch(SourceRange As Range, ColumnNumbers As Variant, SearchTerm As String) As Range

    Dim tmpRange As Range
    Dim i As Long
    Dim SearchRange As Range
    Dim fnd As Range
    Dim firstaddress As String
   
    'Einzelspalte in Array wandeln
    If Not IsArray(ColumnNumbers) Then
        i = ColumnNumbers
        ReDim ColumnNumbers(0)
        ColumnNumbers(0) = i
    End If
       
    'Alle angegebenen Spalten des Quellbereichs zu einem Suchbereich vereinen
    For i = LBound(ColumnNumbers) To UBound(ColumnNumbers)
        If SearchRange Is Nothing Then
            Set SearchRange = SourceRange.Columns(ColumnNumbers(i))
        Else
            Set SearchRange = Union(SearchRange, SourceRange.Columns(ColumnNumbers(i)))
        End If
    Next i
   
    'Innerhalb des festgelegten Suchbereichs suchen...
    Set fnd = SearchRange.Find(what:=SearchTerm, LookIn:=xlValues, lookat:=xlWhole)
   
    If Not fnd Is Nothing Then
        firstaddress = fnd.Address
        Do
            '... und alle Fundstellen mitsamt ihrer Zeile in eine neue Variable packen
            If tmpRange Is Nothing Then
                Set tmpRange = Intersect(SourceRange, fnd.EntireRow)
            Else
                Set tmpRange = Union(tmpRange, Intersect(SourceRange, fnd.EntireRow))
            End If
           
            Set fnd = SearchRange.FindNext(fnd)
        Loop While fnd.Address <> firstaddress
    End If
   
    'Fundbereich zurückgeben. Im Zweifel Nothing
    Set GetRowsWithMultiColumnMatch = tmpRange
End Function

Viele Grüße
derHöpp

Nachtrag: Mit deiner Beispieldatei funktioniert es auch:

Code:

Sub test2()
    Dim wkb As Workbook
    Dim sheetNames As Variant
    Dim sheetSearchColumns As Variant
    Dim tmp As Range
    Dim i As Long
    
    sheetNames = Array("Tabelle1", "Tabelle2", "Tabelle3", "Tabelle4")
    sheetSearchColumns = Array(Array(27, 28, 29, 30, 31), Array(37, 38, 39, 40, 41), Array(54, 55, 56, 57, 58), 3)
    Set wkb = Workbooks("Mappe1(2).xlsx")
    For i = LBound(sheetNames) To UBound(sheetNames)
        Set tmp = GetRowsWithMultiColumnMatch(wkb.Worksheets(sheetNames(i)).Cells(1, 1).CurrentRegion, sheetSearchColumns(i), "Suchbegriff")
        If Not tmp Is Nothing Then tmp.Copy ThisWorkbook.Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next i
End Sub

[Stoffo]

Moin,

vielen Dank @derHoepp. Das funktioniert soweit schon super. Könntest du oder ggf. jemand anders mir noch sagen wie ich es hinbekomme, dass die gefundenen Werte an den entsprechenden Stellen in Mappe 2 eingefügt werden? Also die gefundenen Daten aus Mappe 1 Tabelle 4 in Mappe 2 Tabelle hier sollen die Daten rein A7, die gef. Werte aus M1 Tab 1 in M2 A11 usw. (siehe bsp in mappe 2)? Aktuell werden die Werte untereinander kopiert (nehme an da in einer Variable gespeichert).

EDIT:

Habe es nun wie folgt hinbekommen:

Code:

Sub test2()
    Dim wkb As Workbook
    Dim sheetNames1 As Variant
    Dim sheetSearchColumns1 As Variant
    Dim sheetNames2 As Variant
    Dim sheetSearchColumns2 As Variant
    Dim sheetNames3 As Variant
    Dim sheetSearchColumns3 As Variant
    Dim sheetNames4 As Variant
    Dim sheetSearchColumns4 As Variant
    Dim tmp1 As Range
    Dim tmp2 As Range
    Dim tmp3 As Range
    Dim tmp4 As Range
    Dim i As Long

    sheetNames4 = Array("Tabelle4")
    sheetSearchColumns4 = Array(3)
    Set wkb = ThisWorkbook
    For i = LBound(sheetNames4) To UBound(sheetNames4)
        Set tmp4 = GetRowsWithMultiColumnMatch(wkb.Worksheets(sheetNames4(i)).Cells(1, 1).CurrentRegion, sheetSearchColumns4(i), "Suchbegriff")
        If Not tmp4 Is Nothing Then tmp4.Copy Workbooks.Open("Mappe2.xlsm").Sheets("hier sollen die daten rein").Cells(7, 1).End(xlUp).Offset(1, 0)
    Next i

        sheetNames1 = Array("Tabelle1")
        sheetSearchColumns1 = Array(Array(27, 28, 29, 30, 31))
        Set wkb = ThisWorkbook
        For i = LBound(sheetNames1) To UBound(sheetNames1)
            Set tmp1 = GetRowsWithMultiColumnMatch(wkb.Worksheets(sheetNames1(i)).Cells(1, 1).CurrentRegion, sheetSearchColumns1(i), "Suchbegriff")
            If Not tmp1 Is Nothing Then tmp1.Copy Workbooks.Open("Mappe2.xlsm").Sheets("hier sollen die daten rein").Cells(11, 1).End(xlUp).Offset(1, 0)
        Next i


            sheetNames2 = Array("Tabelle2")
            sheetSearchColumns2 = Array(Array(37, 38, 39, 40, 41))
            Set wkb = ThisWorkbook
            For i = LBound(sheetNames2) To UBound(sheetNames2)
                Set tmp2 = GetRowsWithMultiColumnMatch(wkb.Worksheets(sheetNames2(i)).Cells(1, 1).CurrentRegion, sheetSearchColumns2(i), "Suchbegriff")
                If Not tmp2 Is Nothing Then tmp2.Copy Workbooks.Open("Mappe2.xlsm").Sheets("hier sollen die daten rein").Cells(39, 1).End(xlUp).Offset(1, 0)
            Next i


                sheetNames3 = Array("Tabelle3")
                sheetSearchColumns3 = Array(Array(54, 55, 56, 57, 58))
                Set wkb = ThisWorkbook
                For i = LBound(sheetNames3) To UBound(sheetNames3)
                    Set tmp3 = GetRowsWithMultiColumnMatch(wkb.Worksheets(sheetNames3(i)).Cells(1, 1).CurrentRegion, sheetSearchColumns3(i), "Suchbegriff")
                    If Not tmp3 Is Nothing Then tmp3.Copy Workbooks.Open("Mappe2.xlsm").Sheets("hier sollen die daten rein").Cells(47, 1).End(xlUp).Offset(1, 0)
                Next i
End Sub

Falls jemand Verbesserungspotenzial ersehen kann bitte ich um Vorschläge. Danke und