VBA Blätter filtern und neue Tabelle erstellen.

[Bise del Rio]

Hallo ich möchte gerne zwei Tabellenblätter durchsuchen und dann die Ergebnisse in ein neues Tabellenblatt eintragen.

Erklärung:
Die Reiter "Report" und "All Users" nach den werten aus dem Reiter "Organization1" durchsuchen. Die Ergebnisse sollen in einem neuen Reiter landen, dieser bekommt den Namen aus A1 in Organization1 aber auf 31 Zeichen begrenzt.
Als erstes muss der Reiter "All Users" durchsucht werden. Und Zwar die Spalte K ab Zeile 46 nach dem MFC aus C2 Organization1 und die Spalte D nach A1 Organization 1
Dann muss der Reiter "Report" durchsucht werden. In der Spalte B ab Zeile 9 nacha A1 aus Organization und in H ab Zeile 9 nach G2 aus Organization 1

Die Ergebnisse müssen miteinander verglichen werden. Ein User der sowohl in "All Users" als auch in "Reports" auftaucht ist nicht relevant. Ein User der nur in "All Users" auftaucht soll in dem neu erstellten Reiter eingetragen werden.
Ein Beispiel dafür wie der neue Reiter aussehen soll findet ihr in der Tabelle.

Jetzt soll nach der nächsten Kombination gesucht werden Also A1 C3 und G3
A1 bleibt immer gleich

Das Ergebnis soll ans Ende der im 1. Schritt erstellten Tabelle geschrieben werden.
Das ganze soll für alle Wertepaare durchgeführt werden.
Sobald kein weiterpaar eingetragen ist kann abgebrochen werden.

Ich habe keine Idee, wie ich die Werte Vergleichen soll. Ausserdem werden bei mir auch werte eingetragen die nicht eingetragen werden sollten z.B. B9 aus "Reports" obwohl ich erst ab B10 die werte kopiere.
Im Anhang findet ihr eine kleine Beispieltabelle sowie ein Foto der Fehler.

Ich hoffe ihr könnt mir weiterhelfen.

Mein Code:

Code:

Sub Schaltfläche15_Klicken()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wksO As Worksheet, wksX As Worksheet
Dim i As Long, blnNeu As Boolean
Dim iLastrow1 As Long, iLastrow2 As Long
Set wksO = ThisWorkbook.Worksheets("Organization1")
iLastrow1 = Sheets("All Users").Cells(Rows.Count, 4).End(xlUp).Row
iLastrow2 = Sheets("Report").Cells(Rows.Count, 2).End(xlUp).Row
If Len(wksO.Cells(1, 1)) > 0 Then
If f_x(Left(wksO.Cells(1, 1), 31)) Then
  Set wksX = Worksheets(Left(wksO.Cells(1, 1), 31))
Else
     Set wksX = Worksheets.Add
     wksX.Name = Left(wksO.Cells(1, 1), 31)
     blnNeu = True
End If


For i = 2 To 7
 Sheets("All users").Range("$A$46:$Y$" & iLastrow1).AutoFilter Field:=4, Criteria1:=wksO.Cells(1, 1)
 Sheets("All users").Range("$A$46:$Y$" & iLastrow1).AutoFilter Field:=11, Criteria1:=wksO.Cells(i, 3)
 Sheets("Report").Range("$A$9:$O$" & iLastrow2).AutoFilter Field:=2, Criteria1:=wksO.Cells(1, 1)
 Sheets("Report").Range("$A$9:$O$" & iLastrow2).AutoFilter Field:=8, Criteria1:=wksO.Cells(i, 7)
 Sheets("All users").Range("E47:E" & Sheets("All users").Cells(Rows.Count, 5).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Destination:=wksX.Range("A" & wksX.Cells(Rows.Count, 1).End(xlUp).Row + 1)
 Sheets("Report").Range("B10:B" & Sheets("Report").Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Destination:=wksX.Range("A" & wksX.Cells(Rows.Count, 1).End(xlUp).Row + 1)
 With wksX
   If blnNeu Then
    .Cells(1, 1) = wksX.Name
    .Cells(2, 1) = "User"
    .Cells(2, 2) = "MFC"
    .Cells(2, 3) = "Training Titel"
  End If
 .Range(.Cells(.Cells(.Rows.Count, 2).End(xlUp).Row + 1, 2), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2)) = wksO.Cells(i, 3)
 .Range(.Cells(.Cells(.Rows.Count, 3).End(xlUp).Row + 1, 3), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3)) = wksO.Cells(i, 7)
 End With

Next
 End If
 Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Call Calculate
End Sub


Function f_x(ByVal strTab As String) As Boolean
On Error Resume Next
f_x = Not Worksheets(strTab) Is Nothing
End Function

[Bise del Rio]

Hier ein weitere Versuch, der Code funktioniert aber immernoch nicht einwandfrei.

Code:

Dim vOrg As Variant
Dim vAll As Variant
Dim vRep As Variant
Dim i As Long, lrow As Long, rngUsers As Range, rngRep As Range, j&, k&
Dim blnDrin As Boolean

vOrg = Worksheets("Organization1").Cells(1, 1).CurrentRegion
If worksheetExists(Left(vOrg(1, 1), 31)) Then
  Set wksX = Worksheets(Left(vOrg(1, 1), 31))
Else
     Set wksX = Worksheets.Add
     wksX.Name = Left(vOrg(1, 1), 31)
     With wksX
      .Cells(1, 1) = wksX.Name
      .Cells(2, 1) = "User"
      .Cells(2, 2) = "MFC"
      .Cells(2, 3) = "Training Titel"
     End With
End If
Set rngUsers = Worksheets("All Users").Cells(46, 1).CurrentRegion
Set rngRep = Worksheets("Report").Cells(9, 1).CurrentRegion
lrow = wksX.Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = 1 To UBound(vOrg, 1) - 1
  If sucheInSpalten(rngUsers, 4, vOrg(1, 1), 7, vOrg(i + 1, 3), vAll) Then
      If sucheInSpalten(rngRep, 2, vOrg(1, 1), 6, vOrg(i + 1, 5), vRep) Then
         For j = LBound(vAll) To UBound(vAll)
            blnDrin = False
            For k = 0 To UBound(vRep)
                If Worksheets("All Users").Cells(vAll(j), 5) = Worksheets("Report").Cells(vRep(k), 4) Then
                   blnDrin = True
                   Exit For
                End If
            Next
            If Not blnDrin Then
               wksX.Cells(lrow, 1) = Worksheets("All Users").Cells(vAll(j), 5)
               wksX.Cells(lrow, 2) = Worksheets("All Users").Cells(vAll(j), 11)
               wksX.Cells(lrow, 3) = vOrg(i + 1, 5)
               lrow = lrow + 1
            End If
          Next
      Else
      'eintragen aller Namen vall
       For j = 0 To UBound(vAll)
         wksX.Cells(lrow, 1) = Worksheets("All Users").Cells(vAll(j), 5)
         wksX.Cells(lrow, 2) = Worksheets("All Users").Cells(vAll(j), 11)
         wksX.Cells(lrow, 3) = vOrg(i + 1, 5)
         lrow = lrow + 1
       Next
    End If
  End If
Next

End Sub

Function sucheInSpalten(ByVal rng As Range, ByVal sCol As Integer, ByVal sTxt As String, ByVal offsetCol As Integer, ByVal offsetTxt As String, vresult As Variant) As Boolean
' sucht in 2 Spalten nach Übereinstimmungen , gibt in vresult ein Array mit den Fundzeilen zurück
Dim c As Range
Dim firstaddress As String, strErg As String
With rng
 Set c = .Columns(sCol).Find(what:=sTxt, LookIn:=xlValues, lookat:=xlWhole)
  If Not c Is Nothing Then
    firstaddress = c.Address
     Do
       If c.Offset(, offsetCol) = offsetTxt Then strErg = strErg & "," & c.Row
       Set c = .Columns(sCol).FindNext(c)
     Loop While c.Address <> firstaddress
   End If
  Set c = Nothing
End With
If Len(strErg) Then vresult = Split(Mid(strErg, 2), ",")
sucheInSpalten = Len(strErg) > 0
End Function

Function worksheetExists(ByVal strTab As String) As Boolean
On Error Resume Next
worksheetExists = Not Worksheets(strTab) Is Nothing
End Function

[Bise del Rio]

Was bei mir nicht Funktioniert ist der Vergleich der Zwei arbeitsblätter.
Hier ne Kurze erklärung
1. Wenn nicht vorhanden, soll ein Tabellenblatt mit dem Namen aus "Organization1" Zelle A1 erstellt werden aber auf 31 Zeichen begrenzt
--> Funktioniert!

2. Filtern von "All Users" in Spalte D und K  (D nach A1 aus Organization1 und K nach C2 aus Organization1)
    Filtern von "Report" in Spalte B und H ( B nach A1 aus Organization1 und H nach G2 aus Organization1)
--> Funktioniert!
3. Nachdem gefiltert wurde Vergleich von "All Users" Spalte E und "Reports" Spalte D
    Vergleich: Ein Name der in beiden Spalten auftaucht ist egal.
                    Ein Name der nur in "All Users" steht aber NICHT in "Reports" ist das Ergebnis welches ich suche (Es können auch mehrere Namen sein)
--> Dieser Vergleich funktioniert bei mir nicht, es werden alle Namen die in "All Users" auftauchen in das neue Tabellenblatt geschrieben.

4. Nach dem Eintragen in die Neue Tabelle zurück zu Schritt zwei Diesmal nach A1 C3 und G3 filtern
usw.
--> Funktioniert!

[Steffl]

Hallo,

ich habe eine Frage zu der Codezeile

Code:

If Worksheets("All Users").Cells(vAll(j), 5) = Worksheets("Report").Cells(vRep(k), 4) Then

was steht in den Array vAll und vRep? Das vRep ist doch zweidimensional oder etwas nicht. Ist das vAll zu dem Zeitpunkt überhaupt ein Array?