Hallo,
da ich auf meine letzte Anfrage leider keine Antwort erhalten habe, versuche ich es einfach noch mal mit einer konkreteren Anfrage:
Das Makro soll:
Eine Daten-Ursprungstabelle öffnen und in dieser nacheinander die Datenreihen 9000 bis 27000, 39000 bis 57000 usw. kopieren.
Eine vorhandene Daten-Zielarbeitsmappe öffnen und in dieser die Datenreihen in die jeweilige Tabelle einfügen, je Tabelle eine Datenreihe.
Ich dachte mir ich löse das Problem mit einer verschachtelten For-Next-Schleife habe damit aber Null Erfahrungen.
Das Programm funktioniert für die erste Datenreihe tadellos geht dann aber nicht zur nächsten Datenreihe.
Anschließend sollen die Änderungen gespeichert und die Tabellen geschlossen werden.
Lieber wäre es mir aber wenn der Datentransfer ohne Öffnen der Tabellen funktioniert, da in der Ursprungstabelle ein riesen Diagramm liegt und das Öffnen ewig dauert.
Mit freundlichen Grüßen
Konrad
Sub DatenÜbertragen()
Dim intTab As Integer
Dim rv As Range
Dim dz As Long, ds As Integer
Dim ez As Long, es As Integer 'Variablendeklaration
Const LW = "C:\" 'Konstante: Laufwerksangabe
Const Pfad = "C:\Excel\VBA" 'Konstante: Verzeichnisangabe
ChDrive LW 'Wechsel zu Laufwerk
ChDir Pfad 'Verzeichnis einstellen
On Error GoTo fehler 'Absicherung
Workbooks.Open Filename:="Datenursprung.xlsm", _
ReadOnly:=True 'Arbeitsmappe öffnen für Lesezugriff
dz = 4 'Anfangszeile
ez = dz + 27000 'Endzeile
ds = 1 'Anfangsspalte
es = ds + 1 'Endspalte
Set rv = Range(Cells(dz, ds), Cells(ez, es)) 'ersten Bereich festlegen
Worksheets("Tabelle1").Activate 'Tabelle1 = Datenursprung aktivieren
On Error Resume Next
rv.Select 'ersten Bereich auswählen (Ursprung)
Selection.Copy 'ersten Bereich kopieren (Ursprung)
Workbooks.Open Filename:="Datenziel.xlsx" 'Ziel-Arbeitsmappe öffnen
For dz = 4 To UsedRange.Rows.Count 'Ursprungstabelle: von Zeile 4 bis belegte Zellen
For intTab = 1 To ThisWorkbook.Worksheets.Count 'Zielarbeitsmappe: von Tabelle1 bis zur letzten
Worksheets(intTab).Activate 'jeweiliges Arbeitsblatt aktivieren
On Error Resume Next
Range("B3").Select 'Zelle B3 auswählen
Selection.PasteSpecial _
Paste:=xlPasteAllUsingSourceTheme 'ersten Bereich einfügen (Ziel)
Application.CutCopyMode = False 'Abbrechen Ausschneide- und Kopiermodus
Selection.HorizontalAlignment = xlCenter 'Ausrichtung
Next intTab 'nächste Zielarbeitsmappe
dz = dz + 30000 'neue Anfangszeile in Ursprungstabelle festlegen
Next dz 'Nächste Anfangszeile
'Exit Sub
fehler:
MsgBox "Die angegebene Arbeitsmappe konnte nicht gefunden werden!" 'Anzeige bei fehler
End Sub
|