Excel Makro Formatierung mit kopieren

Question

Hallo VBA Begeisterte:

ich habe folgendes funktionierendes Makro und möchte auch die Formatierung der Spaltenbreite, Zeilenhöhe mit kopieren.

Sub Erst_Bereich_markieren_dann_kopieren_dann_Kopfzeilen_einfügen()

Dim wksSource, wksDestination As Worksheet
'Quelldatenblatt festlegen
Set wksSource = ThisWorkbook.ActiveSheet
'Markierung kopieren
Selection.Copy
'Zieldatenblatt einfügen und festlegen
Set wksDestination = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))
'Einfügen
With wksDestination
.Paste
End With
'Kopfbereich auf Quelldatenblatt kopieren
With wksSource
Range(.Cells(1, 1), .Cells(7, 16)).Copy
End With
'Kopfbereich auf Zieldatenblatt einfügen und Zeilen nach unten verschieben
With wksDestination
.Cells(1, 1).Insert Shift:=xlShiftDown
End With

'Zwischenablage löschen
Application.CutCopyMode = False

End Sub


Ablauf: ich habe ein Tabellenblatt, in der markiere ich einige Zeilen. Der Tabellenkopf wird immer mit den markierten Bereich in ein neues Tabellenblatt kopiert. Funktioniert, aber Formatierung nicht.

Formatierung kopieren mit:

With wksDestination
'PasteSpecial Paste:=xlFormats
'End With
Beim einfügen in den Code in diese Arbeitsmappe und ausführen des Makros bekomme ich bei PasteSpecial Fehlermeldung.

Bin halt nur Anfänger.
Für Hilfe bin ich dankbar!

Kalle

Answer 1

Hallo kalle,

die Spaltenbreite kann nur übernommen werden beim kopieren der gesamten Spalte, Zeile analog. Oder Du liest Sie aus und stellst Sie nachträglich per Code ein.

Gruß Hajo

Answer 2

Hallo Hajo zi,

ich müsste den Formatierungscode in obiges Makro
Sub Erst_Bereich_markieren dann.....
unterbringen.
Nun habe ich für die "Formatierung übertragen" folgenden Code aufgenommen.

Sub Formatierung_übertragen()

Columns("A:P").Select
Selection.Copy
Sheets("Tabelle2").Select
Columns("A:P").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Muster").Select
Range("A1").Select
End Sub

Die Formatierung für die Spalten wird übertragen.
Aber:
1. nur die Formatierung für die Spalten.
2. keine Zeilen werden formatiert.
3. Problem: Anzahl der Zeilen sind unterschiedlich
4. Formatierungscode in Makro "Erst_Bereich_markieren....
Später wird der Name des angelegten Tabellenblatts selbständig benannt, dadurch müsste ich obiges Makro ständig ändern.

Für mich noch nicht zu knacken.
Für Hilfe bin ich dankbar.

Grüße Kalle3

Answer 3

Hallo Kalle,

Option Explicit

Sub Formatierung_übertragen()
Cells.Copy
Sheets("Tabelle2").Cells.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End Sub

Gruß Hajo

Answer 4

Vielen Dank Hajo zi,

Ihr Makro funktioniert einwandfrei.
Nur führe ich mein Makro bis zu 10 Mal aus und dann kann ich Ihr Makro nur 1 Mal anwenden, den alle anderen erzeugten Tabellenblätter haben eine andere Bezeichnung.
Nun habe ich Ihr Makro in meines eingearbeitet, es läuft nur die Formatierung wird nicht übertragen.
Ob Sie mir hier noch helfen könnten?

Auf jeden Fall vielen Dank .

Kalle


Sub Erst_Bereich_markieren_dann_kopieren_dann_Kopfzeilen_einfügen()

Dim wksSource, wksDestination As Worksheet
'Quelldatenblatt festlegen
Set wksSource = ThisWorkbook.ActiveSheet
'Markierung kopieren
Selection.Copy
'Zieldatenblatt einfügen und festlegen
Set wksDestination = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))
'Einfügen
With wksDestination
.Paste
End With
'Kopfbereich auf Quelldatenblatt kopieren
With wksSource
Range(.Cells(1, 1), .Cells(7, 16)).Copy
End With
'Kopfbereich auf Zieldatenblatt einfügen und Zeilen nach unten verschieben
With wksDestination
.Cells(1, 1).Insert Shift:=xlShiftDown
End With



''wechseln auf Tabellenblatt Source
With wksSource
Cells.Copy
With wksDestination
.Cells.PasteSpecial Paste:=xlPasteFormats
End With




'Zwischenablage löschen
Application.CutCopyMode = False

End With

End Sub

Answer 5

Hallo Kalle,

beachte meinen Kommentar, ich vermute so.
Man kann im Forum auch mit Schalter arbeiten, dann ist der Code leichter lesbar.

Option Explicit

Sub Erst_Bereich_markieren_dann_kopieren_dann_Kopfzeilen_einfügen()
Dim wksSource, wksDestination As Worksheet
'Quelldatenblatt festlegen
Set wksSource = ThisWorkbook.ActiveSheet
'Markierung kopieren
Selection.Copy
'Zieldatenblatt einfügen und festlegen
Set wksDestination = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))
'Einfügen Wohin ??? A1 angenommen
wksDestination.Range("A1").Paste
'Kopfbereich auf Quelldatenblatt kopieren
With wksSource
Range(.Cells(1, 1), .Cells(7, 16)).Copy
End With
'Kopfbereich auf Zieldatenblatt einfügen und Zeilen nach unten verschieben
wksDestination.Cells(1, 1).Insert Shift:=xlShiftDown
''wechseln auf Tabellenblatt Source
With wksSource
.Cells.Copy
wksDestination.Cells.PasteSpecial Paste:=xlPasteFormats
'Zwischenablage löschen
Application.CutCopyMode = False
End With
End Sub

Gruß Hajo

Answer 6

Hi,

Ich habe auch mal ein wenig gespielt. Da der "Kopfbereich" ja scheinbar FIX ist habe ich diesen mal zuerst kopiert. Durch PasteSpecial dann Werte/Zellformate, Formatierungen und Spaltenbreiten einzeln im Ziel eingefügt. Nur die Zeilenhöhe lässt sich so wohl nicht übertragen. (Daher der Umweg über ein kleines Array.)

Das selbe Verfahren dann noch einmal mit der ursprünglichen Markierung.

Angenommen die zu kopierende Markierung enthält nicht die gleichen Spalten wie der bereits kopierte "Kopfbereich": Dann düfte in dieser Version die Spaltenbreite evtl. nicht passen. Je nachdem ob der Kopfbereich oder die Markierung die Spaltenbreite im Ziel bestimmen soll, wäre im (nichtbestimmenden) Bereich die Zeile .PasteSpecial Paste:=xlPasteColumnWidths auszumommentieren.

Sub Erst_Bereich_markieren_dann_Kopfzeilen_einfügen_dann_Bereich_kopieren()

Dim wksSource As Worksheet
Dim wksDestination As Worksheet
Dim rngToCopy As Range
Dim dblRHArr() As Double
Dim lngCount As Long

Application.ScreenUpdating = False 'Bildschirmaktualisierung aus

'Quelldatenblatt festlegen
Set wksSource = ThisWorkbook.ActiveSheet
'Markierung merken
Set rngToCopy = Selection
'Zieldatenblatt einfügen und festlegen
Set wksDestination = ThisWorkbook.Worksheets.Add(after:=Sheets(Sheets.Count))

'Kopfbereich auf Quelldatenblatt kopieren
With wksSource.Range(wksSource.Cells(1, 1), wksSource.Cells(7, 16))
.Copy
'zeilenweise Zeilenhöhe auslesen & in Array speichern
For lngCount = 1 To .Rows.Count Step 1
ReDim Preserve dblRHArr(lngCount - 1)
dblRHArr(lngCount - 1) = .Rows(lngCount).RowHeight
Next
End With

'Kopfbereich in Ziel einfügen
With wksDestination.Cells(1, 1)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats 'Werte und Zellformate einfügen
.PasteSpecial Paste:=xlPasteFormats 'Formatierungen einfügen
.PasteSpecial Paste:=xlPasteColumnWidths 'Spaltenbreiten einfügen
'zeilenweise Zeilenhöhe aus Array in Ziel einstellen
For lngCount = LBound(dblRHArr) To UBound(dblRHArr) Step 1
.Offset(lngCount, 0).EntireRow.RowHeight = dblRHArr(lngCount)
Next lngCount
End With

'(Quell-) Markierung kopieren
ReDim dblRHArr(0) 'ZeilenhöhenArray leeren
With rngToCopy
.Copy
For lngCount = 1 To .Rows.Count Step 1
ReDim Preserve dblRHArr(lngCount - 1)
dblRHArr(lngCount - 1) = .Rows(lngCount).RowHeight
Next
End With

'Einfügen
With wksDestination.Cells(8, 1)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats 'Werte und Zellformate einfügen
.PasteSpecial Paste:=xlPasteFormats 'Formatierungen einfügen
.PasteSpecial Paste:=xlPasteColumnWidths 'Spaltenbreiten einfügen
.Select 'Select um Bereichsmarkierung aufzuheben
'zeilenweise Zeilenhöhe aus Array in Ziel einstellen
For lngCount = LBound(dblRHArr) To UBound(dblRHArr) Step 1
.Offset(lngCount, 0).EntireRow.RowHeight = dblRHArr(lngCount)
Next lngCount
End With


'Zwischenablage löschen
Application.CutCopyMode = False
Application.ScreenUpdating = True 'Bildschirmaktualisierung ein

Set wksSource = Nothing
Set wksDestination = Nothing
Set rngToCopy = Nothing
End Sub

bye
malSchauen

Answer 7

Hallo "mal schauen":

ich bin hier wohl auf einen Meister VBA Programmierer gestoßen.
Das Makro funktioniert einwandfrei.
Es schleudert mich zwar beim lesen des Codes, aber das Makro funktioniert einwandfrei.
Dies erspart mir viel Zeit und Mühe.

Kann nur sagen: Danke für die Mühe Ihrerseits.

Wünsche Ihnen ein schönes Wochenende.

PS.: Kaffee gibt´s bei mir immer...

Answer 8

Hallo Hajo Zi,

Makro funktioniert. Ich muss Ihr Makro in das Tabellenblatt dieser Arbeitsmappe kopieren.

Das mit dem Schalter untersuche ich am Wochenende, auch was Option Explicit bedeutet muss ich noch forschen. Beim einfügen des Makros in das Modul wird immer automatisch nach Option Explicit eine waagerechte Linie eingefügt bevor der Rest des Codes aufgelistet wird.??

Auf jeden Fall das Makro läuft nun auch mit Formatierung.

Vielen Dank und ein schönes Wochenende.

Grüße Kalle

PS: Kaffee gibts bei mir immer!!!

Answer 9

Hallo Kalle,

Option Explicit bedeutet das Variablen vor der ersten Verwendung definiert werden müssen. Die meisten Leute die programmieren benutzen diese Einstellung.

Gruß Hajo