Seiteneinrichtung im Makro übernehmen

nok106 · 30.10.2006

Hallo Excelfreunde !

Gibt es hierfür eine Lösung ?

Ich möchte die Zeilenhöhen und Spaltenbreiten - Einstellungen, aus der zu kopierenden Tabelle, im Makro mit übernehmen.

Option Explicit

Sub Kopieren()
Dim VarOben As Long
Dim VarUnten As Long
Dim VarLinks As Long
Dim VarRechts As Long
With Worksheets(16).PageSetup
VarOben = .TopMargin
VarUnten = .BottomMargin
VarLinks = .LeftMargin
VarRechts = .RightMargin
.PaperSize = xlPaperA4
.Orientation = xlPortrait
End With

With Worksheets(17).PageSetup
.TopMargin = VarOben
.BottomMargin = VarUnten
.LeftMargin = VarLinks
.RightMargin = VarRechts
.PaperSize = xlPaperA4
'.Orientation = xlPortrait
.Orientation = xlLandscape
End With

Tabelle16.[A1:K39].Copy Tabelle17.[A1]

End Sub

Hat jemand eine Idee ob das geht und wenn ja - Wie ?

Einstweilen herzlichen Dank an alle, die sich für mich bemühen.

MfG Odje

Matjes · 30.10.2006

Hallo nok106,

ich hab dir mal ein Makro zusammengestellt.
Schau mal, ob es dem entspricht, was du benötigst.

Gruß Matjes

Code:

Sub SelektiertenBereichDesAktivesBlattesAufNeuesBlattKopieren()
'** Der selektierte Bereich eines ArbeitsBlattes wird kopiert
'** (nur ein Bereich, keine Mehrfachselektion)
'** Zieladresse der linken Ecke ist A1
'**
'** Das Seitenlayout wird übernommen
'**
'** Zeilenhöhe und Spaltenbreite werden übernommen

 Dim wb As Workbook, ws As Worksheet, ws2 As Worksheet, r As Range
 Dim x As Long, z As Long, sp As Long
 
 Set wb = ActiveWorkbook
 Set ws = ActiveSheet
 Set r = Selection
 
 If ws.Type &lt;> xlWorksheet Then
  MsgBox Aktives Blatt muß Arbeitsblatt sein.
  GoTo AUFRAEUMEN
 End If
 
 If r.Areas.Count > 1 Then
  MsgBox Nur Selektion eines Bereiches zulässig, keine Mehrfach-Selektion.
  GoTo AUFRAEUMEN
 End If
 
->neues Blatt anlegen
 Set ws2 = wb.Worksheets.Add(After:=ws)
 
->Seitenlayout übernehmen
 With ws.PageSetup
  ws2.PageSetup.BlackAndWhite = .BlackAndWhite
  ws2.PageSetup.BottomMargin = .BottomMargin
  ws2.PageSetup.CenterFooter = .CenterFooter
  ws2.PageSetup.CenterHeader = .CenterHeader
  ws2.PageSetup.CenterHorizontally = .CenterHorizontally
  ws2.PageSetup.CenterVertically = .CenterVertically
  ws2.PageSetup.Draft = .Draft
  ws2.PageSetup.FirstPageNumber = .FirstPageNumber
  ws2.PageSetup.FitToPagesTall = .FitToPagesTall
  ws2.PageSetup.FitToPagesWide = .FitToPagesWide
  ws2.PageSetup.FooterMargin = .FooterMargin
  ws2.PageSetup.HeaderMargin = .HeaderMargin
  ws2.PageSetup.LeftFooter = .LeftFooter
  ws2.PageSetup.LeftHeader = .LeftHeader
  ws2.PageSetup.LeftMargin = .LeftMargin
  ws2.PageSetup.Order = .Order
  ws2.PageSetup.Orientation = .Orientation
  ws2.PageSetup.PaperSize = .PaperSize
 ->** nicht übernehmen, da nur Bereich kopiert wurde
 ->ws2.PageSetup.PrintArea = .PrintArea
  ws2.PageSetup.PrintComments = .PrintComments
  ws2.PageSetup.PrintGridlines = .PrintGridlines
  ws2.PageSetup.PrintHeadings = .PrintHeadings
  ws2.PageSetup.PrintNotes = .PrintNotes
  ws2.PageSetup.PrintQuality = .PrintQuality
  ws2.PageSetup.PrintTitleColumns = .PrintTitleColumns
  ws2.PageSetup.PrintTitleRows = .PrintTitleRows
  ws2.PageSetup.RightFooter = .RightFooter
  ws2.PageSetup.RightHeader = .RightHeader
  ws2.PageSetup.RightMargin = .RightMargin
  ws2.PageSetup.TopMargin = .TopMargin
  ws2.PageSetup.Zoom = .Zoom
 End With

->selektierten Bereich auf neues Blatt A1 kopieren
 r.Copy ws2.Range(A1)

->Zeilehöhen übertragen
 z = 0
 For x = r.Row To r.Row + r.Rows.Count - 1
  z = z + 1
  ws2.Rows(z).RowHeight = ws.Rows(x).RowHeight
 Next
 
->Spaltenbreiten übertragen
 sp = 0
 For x = r.Column To r.Column + r.Columns.Count - 1
  sp = sp + 1
  ws2.Columns(sp).ColumnWidth = ws.Columns(x).ColumnWidth
 Next

AUFRAEUMEN:
 Set wb = Nothing: Set ws = Nothing: Set ws2 = Nothing: Set r = Nothing
End Sub

nok106 · 30.10.2006

Hi Matjes,

das passt ..................

cool ..!! :1

Gruß Odje

Matjes · 30.10.2006

Hab noch eine kleine Korrektur durchgeführt.

Gruß Matjes

Seiteneinrichtung im Makro übernehmen

nok106

Matjes

nok106

Matjes

Seiteneinrichtung im Makro übernehmen

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums