Excel - formátování/tisk do více sloupů na jedné stránce Vyřešeno

[zabacek]

V jiné poradně jsme řešil následující problém:

Prosím o radu: mám text v jednom sloupci v buňkách pod sebou, jedná se o stovky řádků. Potřebuji vše zformátovat (případně pouze vytisknout) tak, abych měl více sloupců (např. 3) vedle sebe na jedné stránce A4 - jako kdybych dal ve Wordu tři sloupce na stránku.
Když vše v současné podobě vytisknu, vyleze mi na každé stránce pouze úzká nudle a stránek je několik desítek
Možná se tento dotaz zdá někomu velice pitomým, ale já jsem řešení skutečně nikde nenašel.
Děkuji předem!


Vynikající poradce navstevnik vytvořil proceduru VBA. Jím vytvořený kód se ale zobrazoval špatně, proto bych ho chtěl poprosit, zda by ho mohl vložit sem.
DÍKY.

[Reklama]

[navstevnik]

Procedura je z drivejsi doby, nyni bych to napsal trochu jinak, ale je funkcni, promenne na zacatku procedury uprav dle potreby, zejmena pocet radku na tiskovou stranu PocetR:

Kód: Vybrat vše

Option Explicit
Sub Sestav()
Dim L1 As String, L2 As String, Hlavicka As Boolean
Dim Blok1 As Range, Blok2 As Range, PocetR As Long, PocetS As Byte
Dim Sl1 As String, Sl11 As String, Sl2 As String, Sl21 As String, PocSl As Byte
Dim OdstupR As Byte, OdstupS As Byte, OfsHl As Byte
Dim i As Integer, j As Byte, k As Byte
Dim PoslR As Long
Dim PosBunka As Range
'
'****************************
' parametry nastavit dle potreby:
  ' prvni radek je/neni hlavicka a tedy bude/nebude vlozena k prvnim blokum tiskoveho listu
  Hlavicka = True 'True / False
  L1 = "pres_sl" ' zdrojovy list
  ' sloupce na zdrojovem listu a prvni blok na cilovem listu musi byt v rozmezi A-Z
  ' jinak je nutno upravit zadani a vypocet poslednich sloupcu Sl11, Sl21
  Sl1 = "A" ' prvni zdrojovy sloupec
  PocSl = 1 ' pocet paralenich sloupcu v n-tici sloupcu
  L2 = "pres_sl" ' cilovy list pro presun
  Sl2 = "F" ' prvni cilovy sloupec pro n-tice sloupcu
  PocetR = 10 ' nastaveni poctu radku na tiskovou stranu
  PocetS = 3 ' nastaveni poctu n-tic sloupcu na tiskovou stranu
  OdstupR = 1 ' odstup bloku radku (pro snazsi naformatovani okraju pro tisk)
  OdstupS = 1 ' odstup n-tic sloupcu
'****************************
  ' nalezeni posledniho radku
  Set PosBunka = Worksheets(L1).Range(Sl1 & ":" & Sl1).Cells(Range(Sl1 & ":" & Sl1).Cells.Count)
  ' presun na posledni neprazny radek listu
  If IsEmpty(PosBunka) Then Set PosBunka = PosBunka.End(xlUp)
  If IsEmpty(PosBunka) Then
    End ' bunka na 1. radku  je take prazdna
  Else
     PoslR = PosBunka.Row
  End If
  '
  OfsHl = 0
  Sl11 = Chr(Asc(Sl1) + PocSl - 1) ' posledni zdrojovy sloupec n-tice
  Sl21 = Chr(Asc(Sl2) + PocSl - 1) ' posledni cilovy sloupec n-tice
  ' vlozeni hlavicek k blokum na cilovem listu
  If Hlavicka Then
    Set Blok1 = Worksheets(L1).Range(Sl1 & CStr(1) & ":" & Sl11 & CStr(1))
    Set Blok2 = Worksheets(L2).Range(Sl2 & CStr(1) & ":" & Sl21 & CStr(1))
    Do
      Blok2.Offset(0, i * (PocSl + OdstupS)).Value = Blok1.Value
      i = i + 1
    Loop While i < PocetS
    OfsHl = 1
  End If
  Set Blok1 = Worksheets(L1).Range(Sl1 & CStr(1 + OfsHl) & ":" & Sl11 & CStr(PocetR + OfsHl))
  Set Blok2 = Worksheets(L2).Range(Sl2 & CStr(1 + OfsHl) & ":" & Sl21 & CStr(PocetR + OfsHl))
  ' presun ze sloupce(u) na listu L1 do bloku na list L2
  i = 0: k = 0 ' k=0 zajisti, ze na prvnim listu nebude OdstupR bloku radku (prazdne radky)
  Do
    j = 0
    Do
      Blok2.Offset(i * (PocetR + (k * OdstupR)), j * (PocSl + OdstupS)).Value _
        = Blok1.Offset((i * PocetR * PocetS) + (j * PocetR), 0).Value
      j = j + 1 ' dalsi n-tice sloupcu
      If (j + (i * PocetS)) * PocetR > PoslR Then End ' ukonceni cyklu
    Loop While j < PocetS
    k = 1 ' bude pridavan OdstupR bloku radku
    i = i + 1 ' dalsi blok n-tic radku
  Loop
End Sub

Na zaver je nutno na cilovem listu upravit sirky sloupcu, pripadne zalomeni textu v bunkach v zavislosti na poctu znaku v radcich zdrojove tabulky.

[zabacek]

Děkuji, funguje to skutečně nádherně!!!