dotNETportal.cz

Zdravím,

mám v Excelu dva listy. Na jednom listě je 30 řádků určených k tisku. Na druhém listu (Seznam zařízení) je tabulka s řádky (řádově stovky), které se pomocí makra vkládají na 1. list.

Makro sloužící ke kopírování vždy 30 řádků.

Public Sub NaplneniTabulky()
  ' na List1 (Tabulka k tisku) jsou v oblasti "$A$4:$T$53" data k tisku...
  ' na List2 (Seznam zarizeni) jsou od A1 data pro vkládání po 30 řádcích do List1 od řádku 7
  Dim i As Integer
  Dim j As Integer
  
  Dim PocetStranek As Integer
  Dim OblastProCopy As Range ' adresa oblasti pro kopírování
  Dim Adresa As String  ' pro sestavení adresy oblasti pro kopírování
  
  Dim OdRadku As Integer
  
  OdRadku = 5 'první řádek (číslo řádku)
  Const PocetRadku As Integer = 30 'počet řádků pro kopírování
  Const CelkemRadku As Integer = 3500 'celkový počet řádků (číslo řádku)
  
  Dim Strana As Integer, StranCelkem As Integer
  ' načtení vstupních hodnot:
  PocetStranek = Sheets("Tabulka k tisku").Range("T2").Value
  Strana = (OdRadku - 1) / PocetRadku + 1
  StranCelkem = PocetStranek + Strana - 1
  
  'ZJIŠTĚNÍ POČTU STRAN
  For j = OdRadku To CelkemRadku 'prohledává záznam 4-3000
  
  'pokud je nalezena prázdná buňka
  If Sheets("Seznam zařízení").Range("B" & j).Value = "" Then
  
    If (j - OdRadku) Mod PocetRadku > 0 Then
            Sheets("Tabulka k tisku").Range("U2").Value = "z " & ((j - OdRadku) \ PocetRadku) + 1
        Else
            Sheets("Tabulka k tisku").Range("U2").Value = "z " & (j - OdRadku) \ PocetRadku
    End If
  
  If Sheets("Tabulka k tisku").Range("U2").Value = "z 0" Then MsgBox "Žádná data k tisku", vbInformation
  
  j = CelkemRadku 'ukončení smyčky
  End If
  
  Next
  

'VKLÁDÁNÍ ŘÁDKŮ DO 1. LISTU
  For i = 1 To PocetStranek
    Adresa = "A" & OdRadku & ":U" & OdRadku + PocetRadku - 1
    Sheets("Seznam zařízení").Range(Adresa).Copy
    Sheets("Tabulka k tisku").Range("A7").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    OdRadku = 5 + PocetRadku
    Strana = (OdRadku - 1) / PocetRadku + 1
    DoEvents
  Next
End Sub

V makru je v podstatě důležité to, že se vybere vždy 30 po sobě jdoucích řádků a vloží se do listu2 (Tabulka k tisku).

Můj problém spočívá v tom, že můžu seznam zařízení třídit. Takže nevidím vždy postupné buňky 1, 2, 3, 4, 5, 6 atd, ale třeba 20, 50, 66, 80 a já bych potřeboval, aby se překopírovaly tyto viditelné buňky.

Vůbec nic, kromě třídění jak v listu, tak v makru (což by bylo asi poměrně složité) mě nenapadá.

Nějaké nápady?

Díky moc

Vybere buňky z oblasti A2:A30, které jsou viditelné (=nejsou vyfiltrované):

Dim rng As Range
Set rng = Range("A2", "A30")
Set rng = rng.SpecialCells(xlCellTypeVisible) 'vybere pouze viditelné buňky

For Each cell In rng
'sem patří požadovaný kód
Next

Díky, ale už jsem to vyřešil po svém.

Když jsem to psal, tak mě nenapadlo, že jsou buňky jenom skrytý.

Použil jsem toto:

'načtení rozsahu ze zdrojového listu a vyfiltrování skrytých buněk
Dim rng As Range
Set rng = Sheets(ZdrojovyList).Range(RozsahNacitani).Rows.SpecialCells(xlCellTypeVisible)

A pak jsem chtěl z tohoto rozsahu rovnou počítat celkový počet řádků a načítat oblast tabulky o 30 řádcích. Ale zde nastal problém.

Pokud nejsou v řádky v RNG kontinuální (jsou řádky např. 1, 2, 3, 6, 7, 8) tak při zjišťování počtu řádku mi funkce vrátí pouze první kontinuální řadu (v tomto případe 3 (= 1, 2, 3) místo 6).

Dále jsem měl problém, když jsem vybral z RNG oblast tabulky o 30 řádcích a nechal je vypsat do listu, tak se vypsaly i ty buňky, které by měli být skryté.

Obě věci jsem vyřešil tím, že RNG vykreslím do skrytého listu a s tím pak pracuju (jak v něm počítám počet řádků, tak z něj kopíruju).

PS.: Když se tak koukám na ten starej kód, tak jsem tam úplně zbytečně kopíroval po řádkách. Mohl jsem zkopírovat celej region a bylo by to. A to počítání řádků jde taky napsat na jeden řádek

'počítání řádků podle záznamů ve sloupci A
PocetRadku = Sheets("temp").Range("A1").End(xlDown).Row

PPS.: Prosím označit, jako vyřešené. Díky