Vložte prosím přílohu.
P.citovat
P.citovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: Popis výrobků
MS Excel
Téma: Popis výrobků 
Zaslal/a 25.8.2015 13:30
Ahoj,
mám dodací list: 1. sloupec název výrobku, 2. sloupec počet ks. Potřebuji vytisknout na A4 (asi do tabulky) názvy výrobků v počtu zadaných kusů. Zkrátka ke každému výrobku, které si zákazník objedná dám popisku.
Předem děkuji za každý tip. Nevím si s tím rady.
Základ som ti vytvoril v prílohe. Určite to pôjde riešiť na 100 spôsobov, ten kód nie je optimálny, ale pre uvedenú potrebu by mal postačovať, pokiaľ som ovšem správne pochopil zadanie..
edit: ešte malá modifikácia kódu z prílohy, spočívajúca v eliminácii nulových hodnôt a pozmenenej konštrukcii cyklov:Sub VytvorStitkyModifikovanyKod()
Dim myRng As Range, myArr() As Variant, i As Integer, j As Integer, k As Integer
Set myRng = [A1].CurrentRegion
Set myRng = myRng.Offset(1, 0).Resize(myRng.Rows.Count - 1, 2)
ReDim myArr(1 To WorksheetFunction.Sum(myRng.Columns(2)))
k = 1
With myRng
For i = 1 To .Rows.Count
If .Cells(i, 2) > 0 Then
For j = 1 To .Cells(i, 2)
myArr(k) = .Cells(i, 1)
k = k + 1
Next j
End If
Next i
End With
Workbooks.Add
Set myRng = [A1]
Set myRng = myRng.Resize(UBound(myArr), 1)
myRng = WorksheetFunction.Transpose(myArr)
Set myRng = Nothing
Erase myArr
End Sub
edit: ešte malá modifikácia kódu z prílohy, spočívajúca v eliminácii nulových hodnôt a pozmenenej konštrukcii cyklov:Sub VytvorStitkyModifikovanyKod()
Dim myRng As Range, myArr() As Variant, i As Integer, j As Integer, k As Integer
Set myRng = [A1].CurrentRegion
Set myRng = myRng.Offset(1, 0).Resize(myRng.Rows.Count - 1, 2)
ReDim myArr(1 To WorksheetFunction.Sum(myRng.Columns(2)))
k = 1
With myRng
For i = 1 To .Rows.Count
If .Cells(i, 2) > 0 Then
For j = 1 To .Cells(i, 2)
myArr(k) = .Cells(i, 1)
k = k + 1
Next j
End If
Next i
End With
Workbooks.Add
Set myRng = [A1]
Set myRng = myRng.Resize(UBound(myArr), 1)
myRng = WorksheetFunction.Transpose(myArr)
Set myRng = Nothing
Erase myArr
End Sub
Příloha: 
26418_pom.zip (13kB, staženo 16x)
citovat26418_pom.zip (13kB, staženo 16x)Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články