VBA Tabelle mit aussortieren suchen

[tw3aker]

Hallo,

ich brauche Hilfe. Gast 123 war so lieb und hat mir unheimlich viel geholfen. Jetzt ist mir nur ein Fehler aufgefallen, der so nicht gut ist.
Aktuell gibt mir die Tabelle dennoch Werte aus, die in I2:I100 stehen.

Folgendes:
Die Tabelle soll eine Andere durchsuchen, nach werten die in der Spalte H2:H100 stehen und dann vergleichen.
Wenn das Makro etwas findet in H, dann soll es schauen, ob in der Spalte I2:I100 einer der eingetragenen Werte übereinstimmt.
Wenn nicht soll er mir die Zeile ausgeben und mit der nächsten Zeile weiter machen.

Ich hoffe ihr könnt mir helfen.

Vielen Dank und Gruß

Code:

Option Explicit        '21.2.2017  Gast 123  Clever Forum
'neu aufgenommen:  Rezeptsuche Neu
Const ASW = "Auswertung"   'Auswertung

'A=gefüllt, D=Ltr, H=Artikel, J=datumgang
Dim rFind As Object, AJ As Object


'Extra Blatt - Produkt5 auflisten
'Invers suche nach Rezepten + Artikel   (No Artikel-Nr !!)

Sub Produkt5_Invers_auflisten()
Dim x As Integer, z As Integer, flg
Dim Adr1 As String, nAdr As String
Dim ATB As Worksheet, AC As Object
Set ATB = Worksheets(ASW)
z = 2   '1. Zeile in Produkt5

With Worksheets("Produkt5")
 'alte Liste ganz löschen
 '.Range("I2:I100") = Empty
 '.Range("K2:K100") = Empty
 .Range("A2:F1000") = Empty

 'Schleife: Rezeptspalte durchsuchen
 For Each AC In .Range("H2:H100")
    If AC.Value = Empty Then Exit For
    'in Spalte H1 Artikel suchen
    Set rFind = ATB.Columns("F").Find(What:=AC, After:=Range("F1"), _
        LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
   
    'Meldung wenn kein Rezept gefunden wurde
    'If rFind Is Nothing Then AC.Cells(1, 0) = "No Find"
    If rFind Is Nothing Then GoTo nxt

    Adr1 = rFind.Address
    x = rFind.Row:  nAdr = Adr1
   
    Do 'Do Schleife für alle Jahrgaenge
       flg = Empty  'Auswertungs Flag
       'Schleife für Artikel Nr. suchen
       For Each AJ In .Range("I2:I100")
         If AJ.Value = Empty Then Exit For
         If ATB.Cells(x, "H") = AJ.Value Then flg = "Find": Exit For
       Next AJ
       '** nur auflisten wenn in Artikel Liste -nicht vorhanden-!!
       If flg = Empty Then
          .Cells(z, 1) = CDate(ATB.Cells(x, 1))  'Datum
          .Cells(z, 2) = ATB.Cells(x, 4).Value   'Fl.Grösse
          .Cells(z, 3) = ATB.Cells(x, 6).Value   'Rezept
          .Cells(z, 4) = ATB.Cells(x, 7).Value   'Flaschen
          .Cells(z, 5) = ATB.Cells(x, 8).Value   'Artikel
          .Cells(z, 6) = ATB.Cells(x, 10).Value  'Jahrgang
           z = z + 1
       End If
      'next Jahrgang Zeile suchen bis Ende
      Set rFind = ATB.Columns("F").FindNext(After:=Range(nAdr))
      nAdr = rFind.Address: x = rFind.Row
    Loop Until rFind.Address = Adr1

nxt:  'überspringen
 Next AC
End With
Columns("A:A").Select
   ActiveWorkbook.Worksheets("Produkt5").Sort.SortFields.Clear
   ActiveWorkbook.Worksheets("Produkt5").Sort.SortFields.Add Key:=Range("A1"), _
       SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
       xlSortTextAsNumbers
   With ActiveWorkbook.Worksheets("Produkt5").Sort
       .SetRange Range("A2:F999999")
       .Header = xlNo
       .MatchCase = False
       .Orientation = xlTopToBottom
       .SortMethod = xlPinYin
       .Apply
   End With
   Range("B1").Select
End Sub

[Steffl]

Hallo,

vielleicht könntest Du die Datei hier hochladen denn nicht jeder hat die Lust deinen alten Thread mit samt der Datei zu suchen.

[tw3aker]

Habs gelöst bekommen.

Vielen Dank

Sieht jetzt so aus:

Code:

Sub Produkt5_Invers_auflisten()
Dim z As Long, i As Long, LRow As Long
Dim ATB As Worksheet
Dim varSearch As Variant
Dim rngC As Range

Set ATB = Sheets("Auswertung")
LRow = ATB.UsedRange.Rows.Count
z = 2   '1. Zeile in Produkt5

With Worksheets("Produkt5")
   'alte Liste ganz löschen
   '.Range("I2:I100").clearcontents
   '.Range("K2:K100").clearcontents
   .Range("A2:F1000").ClearContents
   varSearch = .Range("H2:H100")

   'Schleife: Rezeptspalte durchsuchen
   For i = LBound(varSearch) To UBound(varSearch)
       ATB.UsedRange.AutoFilter field:=6, Criteria1:=varSearch(i, 1)
       If Application.Subtotal(3, ATB.Range("F:F")) > 1 Then
           For Each rngC In ATB.Range("H2:H" & LRow).SpecialCells(xlCellTypeVisible)
               If Application.CountIf(.Range("I2:I100"), rngC) = 0 Then
                   .Cells(z, 1) = CDate(ATB.Cells(rngC.Row, 1))  'Datum
                   .Cells(z, 2) = ATB.Cells(rngC.Row, 4).Value   'Fl.Grösse
                   .Cells(z, 3) = ATB.Cells(rngC.Row, 6).Value   'Rezept
                   .Cells(z, 4) = ATB.Cells(rngC.Row, 7).Value   'Flaschen
                   .Cells(z, 5) = ATB.Cells(rngC.Row, 8).Value   'Artikel
                   .Cells(z, 6) = ATB.Cells(rngC.Row, 10).Value  'Jahrgang
                   z = z + 1
               End If
           Next
       End If
       ATB.ShowAllData
   Next
   .Range("A:F").Sort Key1:=.Range("A1"), order1:=xlAscending, Header:=xlYes
End With
End Sub