Brauche dringend Hilfe bei meinen Makro

Bild

Betrifft: Brauche dringend Hilfe bei meinen Makro
von: Scotty
Geschrieben am: 03.12.2003 10:49:32

Hallo alle zusammen,

habe bei folgenden Makro Probleme:


Sub MultiSpaltenDruck()
Dim rng As Range
Dim iRow As Integer, iCountR As Integer
Dim iRowT As Integer, iColT As Integer
Dim iCounter As Integer
Application.ScreenUpdating = False
Set rng = Range("A1").CurrentRegion
iCountR = 36
Workbooks.Add 1
iRow = 1
iRowT = 1
iColT = 1
Do While iRow <= rng.Rows.Count
   For iCounter = 1 To 2
      rng.Range(rng.Cells(iRow, 1), _
        rng.Cells(iRow + iCountR - 1, 6)).Copy _
        Cells(iRowT, iColT)
      iRow = iRow + iCountR
      iColT = iColT + 7
   Next iCounter
   ActiveSheet.PrintPreview 
   iColT = 1
   Loop
   ActiveWorkbook.Close savechanges:=False
   Application.ScreenUpdating = False
End Sub


Habe 6 schmale Spalten im Querformat. Beim ausdrucken sollen die 6 Spalten der Seite 2 mit auf Seite 1 usw. Ansich funktioniert das Makro. Es gibt nur 2 Probleme: Mein Arbeitsblatt ist im Querformat. Das Makro zeigt aber bei der Druckvorschau Hochformat an. Die Spalten passen dann nicht auf das Blatt. 2. Problem: Die Tabelle geht über mehrere Seiten. Das Makro (Siehe oben:Tabellenumbruch Zeile 36)funktioniert nur auf den ersten beiden Seiten. Wenn man die Zeile 'iCountR = 36' irgendwie ändern könnte, das jede beschriebene Seite am Seitenende "umgebrochen" wird, wäre das Makro perfekt.

Vielleicht kann mir jemand helfen. Bin für jeden Vorschalg dankbar.
Gruß Scotty
Bild


Betrifft: AW: Brauche dringend Hilfe bei meinen Makro
von: Beni
Geschrieben am: 06.12.2003 17:55:44

Hallo Scotty,
ich habe es getestet und hat funktioniert.
Gruss Beni

https://www.herber.de/bbs/user/2345.xls



Sub MultiSpaltenDruck()
Dim rng As Range
Dim iRow As Integer, iCountR As Integer
Dim iRowT As Integer, iColT As Integer
Dim iCounter As Integer
Application.ScreenUpdating = False
Set rng = Range("A1").CurrentRegion
iCountR = 36
Workbooks.Add 1
Columns("A:O").ColumnWidth = 7 '<<<<<<<
iRow = 1
iRowT = 1
iColT = 1
Do While iRow <= rng.Rows.Count
   For iCounter = 1 To 2
      rng.Range(rng.Cells(iRow, 1), _
        rng.Cells(iRow + iCountR - 1, 6)).Copy _
        Cells(iRowT, iColT)
      iRow = iRow + iCountR
      iColT = iColT + 7
   Next iCounter
   ActiveSheet.PageSetup.Orientation = xlLandscape '<<<<<<
   ActiveSheet.PrintPreview
      iColT = 1
   Loop
   ActiveWorkbook.Close savechanges:=False
   Application.ScreenUpdating = True
End Sub



Bild


Betrifft: AW: Brauche dringend Hilfe bei meinen Makro
von: Beni
Geschrieben am: 06.12.2003 17:56:30

Hallo Scotty,
ich habe es getestet und hat funktioniert.
Gruss Beni

https://www.herber.de/bbs/user/2345.xls



Sub MultiSpaltenDruck()
Dim rng As Range
Dim iRow As Integer, iCountR As Integer
Dim iRowT As Integer, iColT As Integer
Dim iCounter As Integer
Application.ScreenUpdating = False
Set rng = Range("A1").CurrentRegion
iCountR = 36
Workbooks.Add 1
Columns("A:O").ColumnWidth = 7 '<<<<<<<
iRow = 1
iRowT = 1
iColT = 1
Do While iRow <= rng.Rows.Count
   For iCounter = 1 To 2
      rng.Range(rng.Cells(iRow, 1), _
        rng.Cells(iRow + iCountR - 1, 6)).Copy _
        Cells(iRowT, iColT)
      iRow = iRow + iCountR
      iColT = iColT + 7
   Next iCounter
   ActiveSheet.PageSetup.Orientation = xlLandscape '<<<<<<
   ActiveSheet.PrintPreview
      iColT = 1
   Loop
   ActiveWorkbook.Close savechanges:=False
   Application.ScreenUpdating = True
End Sub



Bild

Beiträge aus den Excel-Beispielen zum Thema " Tex über Makro einfügen bzw. Markierungen"