Kopieren und Zellen füllen funktioniert nicht

Question

Hallo,

nachdem ich hier schon sehr viel Hilfe erhalten habe, möchte ich noch einmal versuchen ein weiteres Problem zu schildern:
Ich habe es geschafft ein Makro zu erstellen, dass aus einer Tabelle 1 zwei Spalten kopiert und diese an zwei verschiedenen Stellen in einer neuen Tabelle 2 einfügt. Das klappt auch.
Nun das Problem:
In der Tabelle 1 möchte ich im Anschluss des kopierens Bereiche verschieben. Dies sollte mit kopieren und einfügen funktionieren.
Dann sollte in Tabelle 1 noch in zwei Spalten in bestimmten Zellen der Wert „0“ eingetragen werden.
Das verschieben des Bereichs durch kopieren und einfügen sowie das Schreiben des Wer-tes „0“ in bestimmte Zellen funktioniert mit den eingetragenen Code nicht. Eine Fehler-meldung erscheint aber auch nicht.
Wahrscheinlich könnte man das auch "eleganter" erstellen, was mir aber leider nicht gelingt...
Kann mir jemand erklären was ich falsch mache?
Den Code habe ich hier eingefügt:

Sub kopieren()
'Teil 1 rechte Spalte kopieren und ganz rechts in Tabelle 2 in erster freier Spalte einfügen
Sheets("Tabelle1").Activate
Sheets("Tabelle1").Range("L1:L89").Copy
Sheets("Tabelle2").Activate
Cells(1, Range("IV1").End(xlToLeft).Column + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Teil 2 linke Spalte kopieren und vor dem Kriterium "1" als neue Spalte in Tabelle 2 einfügen
For Each c In Sheets("Tabelle2").Range("A1:IV1")
If c = "1" Then
On Error GoTo fehler
c.Offset(0, 0).EntireColumn.Insert 'Spalte einfügen
Sheets("Tabelle1").Range("D1:D109").Copy
c.Offset(1, -1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False 'Auswahl aufheben
Sheets("Tabelle1").Select
Exit Sub
End If
Next c
fehler:
MsgBox ("Der Bereich kann nicht eingefügt werden")
'Teil 3: verschieben der Bereiche von Tabelle 1 durch kopieren und einfügen
Sheets("Tabelle1").Range("E4:H109").Copy
Sheets("Tabelle1").Range("D4:G109").ActiveSheet.Paste

'Teil 4: Werte in bestimmten Zellen auf Null setzen
Sheets("Tabelle1").Activate
Union(Range("Tabelle1!H5:H6"), Range("Tabelle1!H10:H11")).Value = "0.00"
End Sub

Answer 1

Hallo Felix,

probier es mal so:

Sub kopieren()
'Teil 1 rechte Spalte kopieren und ganz rechts in Tabelle 2 in erster freier Spalte einfügen
Sheets("Tabelle1").Range("L1:L89").Copy
Sheets("Tabelle2").Cells(1, Range("IV1").End(xlToLeft).Column + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Teil 2 linke Spalte kopieren und vor dem Kriterium "1" als neue Spalte in Tabelle 2 einfügen
For Each c In Sheets("Tabelle2").Range("A1:IV1")
If c = "1" Then
On Error GoTo fehler
c.Offset(0, 0).EntireColumn.Insert 'Spalte einfügen
Sheets("Tabelle1").Range("D1:D109").Copy
c.Offset(1, -1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False 'Auswahl aufheben
Exit Sub
End If
Next c

fehler:
MsgBox ("Der Bereich kann nicht eingefügt werden")
'Teil 3: verschieben der Bereiche von Tabelle 1 durch Einfügen einer Zelle
Sheets("Tabelle1").Range("E4").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

'Teil 4: Werte in bestimmten Zellen auf Null setzen
Union(Range("Tabelle1!H5:H6"), Range("Tabelle1!H10:H11")).Value = "0.00"

End Sub

Auf

Select

und

Activate

kannst du meistens verzichten.

Gruß

M.O.

Answer 2

Hallo M.O.,

vielen Dank für den Vorschlag.
Ich habe es nicht so gut erklärt und möchte es daher noch einmal erläutern.

Tabelle 1 enthält eine Art Formular mit zwei Eingabereichen (Bereich 1 Spalten D4:H109 und Bereich 2 Spalten L4:P89).
Pro Eingabebereich stehen fünf Spalten (d. h. für fünf Zeiträume) zur Verfügung.
Das Formular soll, wenn es mehr als fünf Zeiträume gibt, den ältestens aus jedem Bereich (d. h. die Werte in den Spalten D bzw. L in eine zweite Tabelle (Tabelle 2) kopieren und dort in den zwei Bereichen einfügen, was ja auch klappt.
Jetzt der "Problemteil":
In Tabelle 1 sollen dann die verbleibenden 4 Zeiträume (Spalten E:H und Spalten M:P) nach links kopiert werden, so dass in der letzten Spalte (H bzw. P) wieder neue Daten eingegeben werden können. Die Formatierung in den Spalten H und P soll erhalten bleiben. Daher sollen im letzten Schritt bestimmte Zellen der Spalten H und P den Wert "0,00" erhalten.
D. h. Teil 3 und Teil 4 werden nicht durchgeführt.
Ich verstehe dies nicht, weil es keine Fehlermeldung gibt ...

Gruß
Felix

Answer 3

Hallo Felix,

wenn bei deinem Code eine 1 im Bereich A1 bis IV1 gefunden wird, startet der Kopiervorgang und dann wird das Makro verlassen:

...
Application.CutCopyMode = False 'Auswahl aufheben
Exit Sub

In diesen Fällen kann dein Teil 3 und 4 gar nicht ausgeführt werden! Dieser Teil wird nur ausgeführt, wenn ein Fehler auftaucht, oder keine 1 in der ersten Zeile gefunden wird.

Gruß

M.O.

Answer 4

Hallo M. O.,

vielen Dank für den Hinweis. Habe jetzt verstanden, dass der Aufbau mit den Bereichen 3 und 4 so nicht funktioniert, da sie immer ausgeführt werden sollen und nicht (nur) bei einem Fehler.
Könntest Du mir erklären, wie ich die Bereiche 3 und 4 in die Schleife integrieren muss, damit sie ausgeführt werden, wenn der Wert "1" erfüllt ist?
Meine Versuche die Bereiche vor der Codezeile Exit Sub einzufügen, führen nur zu Fehlermeldungen.

For Each c In Sheets("Tabelle2").Range("A1:IV1")
If c = "1" Then
On Error GoTo fehler
c.Offset(0, 0).EntireColumn.Insert 'Spalte einfügen
Sheets("Tabelle1").Range("D1:D109").Copy
c.Offset(1, -1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False 'Auswahl aufheben
'hier einbinden funktioniert nicht
Exit Sub

Gruß
Felix

Answer 5

Hallo Felix,

versuch es mal so:

Sub kopieren_neu()
'Teil 1 rechte Spalte kopieren und ganz rechts in Tabelle 2 in erster freier Spalte einfügen
Worksheets("Tabelle1").Range("L1:L89").Copy
Worksheets("Tabelle2").Cells(1, Range("IV1").End(xlToLeft).Column + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

'Teil 2 linke Spalte kopieren und vor dem Kriterium "1" als neue Spalte in Tabelle 2 einfügen
For Each c In Worksheets("Tabelle2").Range("A1:IV1")
If c = "1" Then
On Error GoTo fehler
c.Offset(0, 0).EntireColumn.Insert 'Spalte einfügen
Worksheets("Tabelle1").Range("D1:D109").Copy
c.Offset(1, -1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False 'Auswahl aufheben
Exit For
End If
Next c

'Teil 3: verschieben der Bereiche von Tabelle 1 durch kopieren und einfügen
Worksheets("Tabelle1").Range("E4:H109").Copy Destination:=ThisWorkbook.Worksheets("Tabelle1").Range("D4")

'Teil 4: Werte in bestimmten Zellen auf Null setzen
Union(Range("Tabelle1!H5:H6"), Range("Tabelle1!H10:H11")).Value = "0.00"

Exit Sub

fehler:
MsgBox ("Der Bereich kann nicht eingefügt werden")

End Sub

Gruß

M.O.

Answer 6

Hallo M. O.,

vielen Dank für die Hilfe!
Es funktioniert wie gewünscht.

Gruß
Felix