Option Explicit
Sub main()
Dim wbStart As Workbook, wbZiel As Workbook
Dim lob As Excel.ListObject
Dim lobRow As Excel.ListRow
Dim rng As Excel.Range, rngIsect As Excel.Range
Dim x As Long
Application.ScreenUpdating = False
Set wbStart = ThisWorkbook
Set wbZiel = Workbooks.Open("c:\Test\master.xlsm")
Set lob = wbZiel.Worksheets(1).ListObjects("Tabelle3")
With wbStart.Worksheets("ExternBasis")
If .AutoFilterMode Then .AutoFilterMode = False
Set rng = .Range("A1:L" & .Cells(.Rows.Count, "L").End(xlUp).Row)
rng.AutoFilter Field:=8, Criteria1:="<>Leer"
Set rngIsect = Intersect(rng, rng.SpecialCells(xlCellTypeVisible), rng.Offset(1))
End With
If Not rngIsect Is Nothing Then
For x = 1 To rngIsect.Areas.Count Step 1
Set lobRow = lob.ListRows.Add
With lobRow
.Range.Resize(rngIsect.Areas(x).Rows.Count, rngIsect.Areas(x).Columns.Count).Value = rngIsect.Areas(x).Value
End With
Next x
End If
Application.CutCopyMode = False
MsgBox "Übertragung erfolgreich !!!"
Application.ScreenUpdating = True
End Sub