Hallo Katrin,
öffne die Master.xlsm und lösche ab Zeile 2 bishin zur letzten blauen Zeile alles raus.
Am Ende zeigt diese Tabelle nurnoch zwei blaue Zeilen.
Zeile 1 überschrift; Zeile 2 leer.
Anschließend öffnest Du Transfertest.xlsm. Im Projektexplorer legst Du ein allgemeines Modul an und fügst folgenden Code da ein:
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") '########## anpassen ##############
Set lob = wbZiel.Worksheets(1).ListObjects("Tabelle3")
'
With wbStart.Worksheets("ExternBasis")
'wenn Filter gesetzt -> entfernen
If .AutoFilterMode Then .AutoFilterMode = False
'Tabellenbereich feststellen
Set rng = .Range("A1:L" & .Cells(.Rows.Count, "L").End(xlUp).Row)
'Filter setzen -> Spalte H -> "Leer" ------------> ernsthaft?
rng.AutoFilter Field:=8, Criteria1:="<>Leer"
'Ergebnismenge in Objectreferenz
Set rngIsect = Intersect(rng, rng.SpecialCells(xlCellTypeVisible), rng.Offset(1))
End With
'prüfen, ob Filtrat eine Ergebnismenge bereitstellt
If Not rngIsect Is Nothing Then
'wenn Ergebnismenge vorhanden, neue Zeile anlegen
For x = 1 To rngIsect.Areas.Count Step 1
Set lobRow = lob.ListRows.Add
With lobRow
'Zeile auf Ergebnismenge vergössern + eintragen
.Range.Resize(rngIsect.Areas(x).Rows.Count, rngIsect.Areas(x).Columns.Count).Value = rngIsect.Areas(x).Value
End With
Next x
End If
'wbZiel.Sheets("Basisdaten_Jewelbox").Cells(x, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Workbooks("master.xlsm").Close True
MsgBox "Übertragung erfolgreich !!!"
Application.ScreenUpdating = True
End Sub
Anschließend in der Mappe Transfertest.xlsm ein Rechtsklcik auf den Blattnamen "ExternBasis" -> rechtsklick -> Code anzeigen.
|