AW: Kriterium abgleichen und Datensatz kopieren
05.05.2017 16:28:56
ChrisL
Hi
Ich bin mal so frech und poste ein Makro ;)
Der Code soll in die Mappe "Auswahl". Blatt 2 darf nicht bereits vorhanden sein.
Prinzip: ganze Tabelle "Gesamt" kopieren. In der letzten leeren Spalte =ZÄHLENWENN(G2,Tabelle1!A:A) einsetzen. Nach 0 (null) Werten filtern d.h. nicht vorhandene sind sichtbar. Dann alle sichtbaren Zeilen löschen und Filter wieder entfernen.
Sub Makro1()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim lSpalte As Long, lZeile As Long
Application.ScreenUpdating = False
Set WS1 = ThisWorkbook.Worksheets("Tabelle1")
Workbooks("Gesamt.xlsx").Worksheets("Bayern_Gesamt").Copy After:=ThisWorkbook.Sheets(Sheets. _
Count)
Set WS2 = ActiveSheet
With WS2
WS2.Name = "Blatt 2"
lSpalte = WS2.Cells(1, Columns.Count).End(xlToLeft).Column + 1
lZeile = WS2.Cells(Rows.Count, 1).End(xlUp).Row
.Range(.Cells(2, lSpalte), .Cells(lZeile, lSpalte)).Formula = _
"=COUNTIF(G2," & WS1.Name & "!A:A)"
With .Range("A1:" & .Cells(lZeile, lSpalte).Address(0, 0))
.AutoFilter
.AutoFilter Field:=lSpalte, Criteria1:="0"
WS2.Range("A2:" & .Cells(lZeile, lSpalte).Address(0, 0)).SpecialCells(xlCellTypeVisible) _
.EntireRow.Delete
.AutoFilter
End With
.Columns(lSpalte).Delete
End With
End Sub
cu
Chris