Aufzeichnungsmakro optimieren

Hallo,
ich habe ein Makro aufgezeichnet das funktioniert. Eine Optimierung ist mir leider nicht gelungen. Das Makro kopiert aus 9 verschiedenen Tabellen Inhalte in eine "Zieltabelle" LLDirneu, jeweils in unterschiedliche Zeilen ab Spalte FK. Dabei müssen die "Werte" eingetragen werden, also nicht die in den Kopiertabellen vorhandenen Formeln.
Bereiche die kopiert werden aus den 9 Tabellen:
immer ab Zeile 2, Spalte AY
derzeit bis incl. Spalte DI (diese Spalte verändert sich um eine Spalte nach rechts in unregelmäßigen Abständen)
Zeilenanzahl ist zum Teil unterschiedlich
Besonderheit: Das Makro habe ich in einer separaten ".xlsm-Datei" abgespeichert; die betroffenen Tabellen befinden sich in der Datei: 3012autneu4.xlsx
aktuelles Makro:

Sub Kopie9()
Windows("3012autneu4.xlsx").Activate
Sheets("FK9201").Select
Range("AY2:DI2485").Select
Selection.Copy
Sheets("LLDirneu").Select
Application.Goto Reference:="R9201C167"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Erg12202").Select
Range("AY2:DI590").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("LLDirneu").Select
Application.Goto Reference:="R12202C167"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("FK13201").Select
Range("AY2:DI106").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("LLDirneu").Select
Application.Goto Reference:="R13201C167"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("FK13701").Select
Range("AY2:DI106").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("LLDirneu").Select
Application.Goto Reference:="R13701C167"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("FK14301").Select
Range("AY2:DI2485").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("LLDirneu").Select
Application.Goto Reference:="R14301C167"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("FK17001").Select
Range("AY2:DI2485").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("LLDirneu").Select
Application.Goto Reference:="R17001C167"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("FK19501").Select
Range("AY2:DI2485").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("LLDirneu").Select
Application.Goto Reference:="R19501C167"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("FK22001").Select
Range("AY2:DI2485").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("LLDirneu").Select
Application.Goto Reference:="R22001C167"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("FK25002").Select
Range("AY2:DI440").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("LLDirneu").Select
Application.Goto Reference:="R25002C167"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("FK25001").Select
Windows("EL-Kopie-Makro.xlsm").Activate
End Sub

Meine Bitte wäre eine Vereinfachung zumindest in der Form, dass ich die Änderungen der Spalte DI nach rechts nur 1x eingeben/ändern muss. Die Kopiertabellen werden sukzessive mehr, so dass der Änderungsaufwand immer steigt.
Vielen Dank für eine Hilfe.
mfg

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Kopie9() Dim wks As Worksheet Dim LetzteSpalte As Long Const strSpalte As String = "DI" LetzteSpalte = Range(strSpalte & "1").Column With Workbooks("3012autneu4.xlsx") For Each wks In .Worksheets If wks.Name Like "FK*" Then With wks .Range(.Cells(2, 6), .Cells(Rows.Count, 6).End(xlUp)).Resize(, LetzteSpalte - 5).Copy End With .Sheets("LLDirneu").Cells(Rows.Count, 167).End(xlUp).Offset(1).PasteSpecial _ xlPasteValues End If Next wks End With End Sub

Sub Kopie9() Dim wks As Worksheet Dim nxz As Long nxz = 2 'Next Zeile mit Leerzeile With Workbooks("3012autneu4.xlsx") .Sheets("LLDirneu").UsedRange.Offset(1, 0).ClearContents For Each wks In .Worksheets If wks.Name Like "FK*" Then With wks .Range("AY2:DJ" & .Cells(Rows.Count, "AY").End(xlUp).Row).Copy End With .Sheets("LLDirneu").Cells(Rows.Count, 167).End(xlUp).Offset(nxz, 0).PasteSpecial _ xlPasteValues End If Next wks End With End Sub

Hallo
mein Tipp, du kannst ja eine Kopie Datei erstellen, in der With Klammer den Kopie Namen angeben, und das Makro in der Kopie Datei laufen lassen. Die nxz Variable bezieht sich hierauf: - .End(xlUp).Offset(nxz, 0) - End(xlUp)
sucht die letzte Zeile in Spalte 167, und fügt den Wert nxz dazu. Er muss mindestens 1 sein, sonst überschriebt man die letzte Zeile mit den Folgedaten! Du kannst aber auch beliebig viele Leerzeilen zwischen den Datenblöcken setzen. Es dient nur der optischen Übersicht um die einzelnen Blöcke Unterscheiden zu können! Wenn nicht gewünscht auf 1 setzen, dann ist alles fortlaufend.
Mein Rat ist jedes neue Makro grundsaetzlich NIE in der Originaldatei zu testen, sondern im Beispiel. Da kannst du keine Original Daten zerstören, erkennst aber die VBA Funktion. So lernt man am schnellsten Makros verstehen.
mfg Piet

Sub Kopie9() Dim wkbMakro As Workbook Dim wkbDaten As Workbook Dim wksZiel As Worksheet Dim strSpa As String Dim StatusCalc As Long Dim aWks() As Worksheet, aZeile() As Long, aZiel() As Long, intD As Integer Set wkbMakro = ThisWorkbook Set wkbDaten = Application.Workbooks("3012autneu4.xlsx") Set wksZiel = wkbDaten.Worksheets("LLDirneu") strSpa = "DI" 'letzte zu kopierende Spalte intD = 9 'Anzahl Blätter aus denen kopiert werden soll ReDim aWks(1 To intD) 'Datenarray für Tabellenblätter mit Formeln ReDim aZeile(1 To intD) 'Datenarray für letzte zu kopierende Zeile im Blatt ReDim aZiel(1 To intD) 'Datenarray für Einfüge-Zeile im Ziel-Blatt With wkbDaten 'Tabellenblätter mit Formeln Letzte Zeile Einfüge-Zeile Set aWks(1) = .Worksheets("FK9201"): aZeile(1) = 2485: aZiel(1) = 9201 Set aWks(2) = .Worksheets("Erg12202"): aZeile(2) = 590: aZiel(2) = 12202 Set aWks(3) = .Worksheets("FK13201"): aZeile(3) = 106: aZiel(3) = 13201 Set aWks(4) = .Worksheets("FK13701"): aZeile(4) = 106: aZiel(4) = 13701 Set aWks(5) = .Worksheets("FK14301"): aZeile(5) = 2485: aZiel(5) = 14301 Set aWks(6) = .Worksheets("FK17001"): aZeile(6) = 2485: aZiel(6) = 17001 Set aWks(7) = .Worksheets("FK19501"): aZeile(7) = 2485: aZiel(7) = 19501 Set aWks(8) = .Worksheets("FK22001"): aZeile(8) = 2485: aZiel(8) = 22001 Set aWks(9) = .Worksheets("FK25002"): aZeile(9) = 440: aZiel(9) = 25002 .Activate End With wksZiel.Activate 'Makrobremsen lösen With Application .ScreenUpdating = False StatusCalc = .Calculation .Calculation = xlCalculationManual End With 'Tabellenblätter abarbeiten For intD = 1 To UBound(aWks) aWks(intD).Range("AY2:" & strSpa & aZeile(intD)).Copy wksZiel.Cells(aZiel(intD), 167).PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False Next Range("FK25001").Select wkbMakro.Activate 'Makrobremsen zurücksetzen With Application .ScreenUpdating = True If StatusCalc 0 Then .Calculation = StatusCalc End With End Sub

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread