AW: Kopiere Daten in viele andere Blätter
09.04.2020 11:13:22
Regina
... dann teste mal diesen Code:
Die Zieldatei ist geschlossen und liegt im gleichen Pfad wie die Datei mit dem Code. Den namen der Zieldatei musst Du im Code anpassen.
Das schließen der Zieldatei nach erfolgter Übertragung ist im Code ertsmal auskommentiert, damit das Ergebnis "gleich" sichtbar ist.
Public Sub Uebertrag()
Dim obj_wks_ziel As Worksheet
Dim obj_wks_quelle As Worksheet
Dim obj_wkb As Workbook
Dim obj_wkb_ziel As Workbook
Dim lng_zeile_ziel As Long
Dim lng_zeile As Long
Dim rng_zeile As Range
Dim str_zielblatt As String
Set obj_wkb = ThisWorkbook
Set obj_wks_quelle = obj_wkb.Worksheets("Tabelle1") ' Hier Quelltabellenblatt benennen
Set obj_wkb_ziel = Workbooks.Open(ThisWorkbook.Path & "\zieldatei.xlsx") ' Dateiname bitte _
anpassen!
lng_zeile = 4 ' Startzeile im Quellblatt
With obj_wks_quelle
Do Until .Cells(lng_zeile, 1) = "" ' Quellblatt ab Zeile 2 bis zur ersten leeren Zelle in _
A durchlaufen
str_zielblatt = .Cells(lng_zeile, 2)
Set obj_wks_ziel = obj_wkb_ziel.Worksheets(str_zielblatt) ' Hier Zieltabellenblatt _
benennen
Set rng_zeile = obj_wks_ziel.Columns(1).Find(.Cells(lng_zeile, 1))
If Not rng_zeile Is Nothing Then
lng_zeile_ziel = rng_zeile.Row
.Range(.Cells(lng_zeile, 3), .Cells(lng_zeile, 7)).Copy obj_wks_ziel.Cells( _
lng_zeile_ziel, 2)
End If
lng_zeile = lng_zeile + 1
Loop
End With
' obj_wkb_ziel.Close savechanges:=True
End Sub
Gruß Regina