VBA beim Kopieren auch die Zeilenhöhen mit übernehmen

[so.egal]

Hallo zusammen,

ich habe ein Macro, welches mir bestimmte Zellen kopiert. Die Zeilenhöhen werden aber nicht berücksichtigt. Gibt es eine Möglichkeit, dass die Zeilenhöhe entsprechen des kopierten Sheets übernommen wird?

Hier der Code:

Code:

Sheets("Brief 1 (GME)").Cells.Delete
    'Sheets("Brief Test").Cells.clear
         
       'kopiert sichtbare Zellen im Sheet im Bereich G1:GJ28 und fügt sie im Worksheet (Brief GME) ein
       'wenn auf einem Niveau kein Brief vorhanden ist, geht wird es übersprungen (ohne "on Error resume next" entsteht ein Laufzeitfehler)
     On Error Resume Next
        Sheets("Brief 1 (G)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Copy Worksheets("Brief 1 (GME)").Cells(1, 1)
        Sheets("Brief 1 (M)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Copy Worksheets("Brief 1 (GME)").Cells(29, 1)
        Sheets("Brief 1 (E)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Copy Worksheets("Brief 1 (GME)").Cells(57, 1)
    On Error GoTo 0

        'Seitenumbruch vor Zeilen 29 und 58
         Worksheets("Brief 1 (GME)").HPageBreaks.Add Before:=Worksheets("Brief 1 (GME)").Rows(29)
         Worksheets("Brief 1 (GME)").HPageBreaks.Add Before:=Worksheets("Brief 1 (GME)").Rows(57)
 

 
LG Tina

[{Boris}]

Hi,

pass die Zeilenhöhe im Anschluss des Kopiervorgangs immer direkt an - nach diesem Muster:

Code:

Sub til()
Rows(10).Copy Rows(2)
Rows(2).RowHeight = Rows(10).RowHeight
End Sub

[Gast 123]

Hallo

statt jede Zeile einzeln anzupassen würde ich den gesamten Bereich auf einheitliche Zeilenhöhe setzen. Sofern im Bereich Daten enthalten sind.

mfg Gast 123

Code:

Sub test()
'Zeilenhöhe nur kopueren wenn Daten vorhanden sind!
Zahl = Sheets("Brief 1 (G)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Count
If Zahl > 0 Then Sheets("Brief 1 (G)").Rows("1:28").Copy Worksheets("Brief 1 (GME)").Rows(1)

Zahl = Sheets("Brief 1 (G)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Count
If Zahl > 0 Then Sheets("Brief 1 (M)").Rows("1:28").Copy Worksheets("Brief 1 (GME)").Rows(29)

Zahl = Sheets("Brief 1 (G)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Count
If Zahl > 0 Then Sheets("Brief 1 (E)").Rows("1:28").Copy Worksheets("Brief 1 (GME)").Rows(57)

'kopierte Daten wieder löschen für SpecialCells.Visible!
Worksheets("Brief 1 (GME)").Rows("1:100").ClearContents

'** Hier das normale Kopierprogramm:
End Sub

---

Hallo

bei der 1. Lösung hatte ich wohl einen kleinen Denkfehler. Spielt keine Rolle, dann probier es bitte mal so:
Hinweis:  Der Befehl GoSub ist im Forum nicht üblich, ich verwende ihn trotzdem. Er muss aber mit EXIT SUB beendet werden!!

mfg Gast 123

Code:

Sub Zeilenhöhe()
Dim Brief As Worksheet, z As Integer, Zahl As Integer
Sheets("Brief 1 (GME)").Cells.Delete
     On Error Resume Next
        Sheets("Brief 1 (G)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Copy Worksheets("Brief 1 (GME)").Cells(1, 1)
        Sheets("Brief 1 (M)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Copy Worksheets("Brief 1 (GME)").Cells(29, 1)
        Sheets("Brief 1 (E)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Copy Worksheets("Brief 1 (GME)").Cells(57, 1)
    On Error GoTo 0

        'Seitenumbruch vor Zeilen 29 und 58
         Worksheets("Brief 1 (GME)").HPageBreaks.Add Before:=Worksheets("Brief 1 (GME)").Rows(29)
         Worksheets("Brief 1 (GME)").HPageBreaks.Add Before:=Worksheets("Brief 1 (GME)").Rows(57)

'Zeilenhöhe durch Unterrprogramm einstellen
Zahl = Sheets("Brief 1 (G)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Count
If Zahl > 0 Then Set Brief = Sheets("Brief 1 (G)"):  z = 1:  GoSub Zeilenhöhe

Zahl = Sheets("Brief 1 (M)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Count
If Zahl > 0 Then Set Brief = Sheets("Brief 1 (M)"):  z = 29:  GoSub Zeilenhöhe

Zahl = Sheets("Brief 1 (E)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).Count
If Zahl > 0 Then Set Brief = Sheets("Brief 1 (E)"):  z = 57:  GoSub Zeilenhöhe
Exit Sub    'Makro mit EXIT SUB beenden!!
 
Zeilenhöhe:  'UNTERPROGRAMM FÜR ZEILENHÖHE
    For j = 1 To 29
        Worksheets("Brief 1 (GME)").Rows(z).RowHeight = Brief.Rows(j).RowHeight
        z = z + 1
    Next j
    Return
End Sub

[Kuwer]

Hallo Tina,

kopiere einfach die ganze(n) Zeile(n), denn dann wird auch das Format dieser übertragen:

Sheets("Brief 1 (G)").Range("G1:GJ28").SpecialCells(xlCellTypeVisible).EntireRow.Copy Worksheets("Brief 1 (GME)").Cells(1, 1)

Gruß Uwe

[Gast 123]

Hallo

wie amüsant, dann war meine 1. Variante alle Zeilen als Row zu kopieren doch richtig.  Ich war da im Zweifel ....

mfg Gast 123

[so.egal]

Hat leider nicht geklappt. Es ergab ein Problem mit nem HPageBrake.delete darunter. 
Habs mit ner Hilfsspalte gelöst, die ich nach dem Zeilenanpassen einfach ausgeblendet.
Hab auch die anderen Sachen getestet. Aber es hat immer irgendwo gehakt. Kann auch mit Zellverbünden zu tun haben.
Ich danke euch trotzdem vielmals!!!
LG Tina

[{Boris}]

Hi,

Kann auch mit Zellverbünden zu tun haben

100%ig.