potřeboval bych najit funkci s určitými vlastnostmy a to:
přesunout (skopírovat) nebo vytisknout řádek je li v určit buňce v tom řádku více než nula.
předem děkuji za návrhy

Kód: Vybrat vše
Option Explicit
Sub PresunATiskni()
Dim SBlok As Range, SCll As Range, TCll As Range, i As Long
' definice bloku bunek s poctem kusu
With Worksheets("list1")
Set SBlok = Intersect(.UsedRange, .Range("c:c"))
End With
'aktivace pomocneho listu list2
With Worksheets("list2")
' odstranit obsah na listu2
.UsedRange.EntireRow.Delete
' definice cile pro sestaveni tiskoveho listu
Set TCll = .Range("a1:d1")
i = 0
' vyhledavaci smycka
For Each SCll In SBlok.Cells
If SCll.Value > 0 Then
' preneseni radku splnujiciho podminku (i hlavickoveho)
TCll.Offset(i, 0).Value = SCll.Resize(1, 4).Offset(0, -2).Value
i = i + 1
End If
Next SCll
' vyber tabulky k tisku
.UsedRange.Columns.AutoFit
' zde je nastaveno nahled - Preview:=True, pro tisk na tiskarnu nastav Preview:=False
.UsedRange.PrintOut Copies:=1, Preview:=True, Collate:=True
End With
End Sub
Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 10 hostů