makro - excel podmineny tisk Vyřešeno

[Petrrr]

Zdravim zhruba neco okolo 14 dni se snazim prijit na makro, ktere by mi udelalo presne toto

mam formular do ktereho se podle cisla nactou data (nasledne je nutne tento dokument vytisknout)
vzhledem k stehovani a vzdalenosti od tiskarny momentalne to je k tiskarne docela prochazka :)

mam cisla (pro ktera se ma dany formular nacist) za nimi jsem si spachal podminku kde je odpovedeni z funce kdyz coz je konecna funkce 1 - 0
->1 ano ma se vytisknout
pokud se ma vytisknout chtel bych aby se cislo z toho radku zkopiroval a vytiskl uz jen funkci jsem provedl, ze se po zkopirovani toho cisla do prvni bunky ve sloupci funkce za cislem prepise na 0 -> na tom radku uz nebude pak 1 nebude oznacen jako ten k tisku

nasledne aby to udelal se vsemi bunkami kde je 1

po poslednim vystupu uz nebudou v druhem sloupci zadne 1 - suma sloupce bude 0

co jsem tak koukal dokazi udelat jen manualni makra na tisk ale nedokazi mu do toho zapsan nejakou podminku

Byl bych moc rad kdyby mi nekdo poradil co jsem se tak prokousaval tak jsem nikde nenasel podminky do VBA

neco jako kdyz ( pozice bunky) = 1
copy (sloupec - 1 ten samej radek) copy do prvni bunky sloupce
tisk
to same pro dalsi bunku atd

diky moc predem

[Reklama]

[Petrrr]

Kód: Vybrat vše

Sub Zkouska()
'
' zkouska Makro
' tisk souboru
'

'
ActiveWindow.SelectedSheets.PrintOut Copies:=1

If Range("C1") <> "" Then

    Range("B2").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
If Range("C1") <> "" Then

    Range("B3").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B4").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B5").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B6").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B7").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B8").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B9").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B10").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B11").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B12").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B13").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B14").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B15").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   
    If Range("C1") <> "" Then

    Range("B16").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
   

End Sub


Takto jsem si zhruba sesmolil jedno makro, otazka zda to bude delat co potrebuju, momentalne to jdu zkouset

mno tak pro dnesek asi na to kaslu

Kód: Vybrat vše

Sub Tiskseznamu()
'
' tisk souboru
'

'

If Range("C1") <> "" Then
    Worksheets("List1").Range("B2").Select
    ActiveSheet.Copy
Worksheets("List1").Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    End If
ActiveWindow.SelectedSheets.PrintOut Copies:=1
If Range("C1") <> "" Then

    Range("B3").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B4").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=12
    End If
   
If Range("C1") <> "" Then

    Range("B5").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B6").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B7").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B8").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B9").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B10").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B11").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B12").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B13").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B14").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B15").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   
If Range("C1") <> "" Then

    Range("B16").Select
    ActiveSheet.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    End If
   

End Sub


napsal jsem tuto strukturu, ale co se mi deje ted je ze mi to v casti kodu po if targetne B2 dokonce ji to snad i skopci ale funkci na target B1 uz to jen napise do bunky :) a dal makro nic nedela

[cmuch]

Nejak se v tom ztracim, bud vysvetli jeste jednou lepe nebo priloz sesit.

[Azuzula]

Pokud vidím správně, tak během splnění první podmínky se makro ukončí příkazem "end" potom už to nejde na další podmínku a ani se nespustí tisk. A vzhledem k tomu, že jsou všechny podmínky stejné, tak bych spíš volila cyklus For Next.

Ve třetí podmínce má být tisk 12ti kopií? Tipuju že to je překlep.

Beru v potaz buňky pro které máš makro napsané teď. Pokud chceš změnit rozsah, tak stačí přepsat číslo na řádku for i = 2 to 16 což je poslední podmínka tvého makra, v případě měnícího se počtu řádků stačí to číslo nahradit počítadlem.

Kód: Vybrat vše

Cells(Rows.Count, 1).End(xlUp).Row

najde poslední zapsanou buňku v prvním sloupci

Makro s cyklem bude vypadat asi takhle:

Kód: Vybrat vše

Sub tisk_souboru()
Dim i As Integer

Sheets("List1").Select
If Range("C1") <> "" Then
    For i = 2 To 16 'poslední řádek
        Range("B1") = Range("B" & i)
        ActiveWindow.SelectedSheets.PrintOut Copies:=1
    Next
End If
End Sub

[Petrrr]

Azuzula super akorat to tam musim nejak vycapat aby tam tu bunku zkopiroval coz myslim chapu (doufam) ted akorat vytiskne tolikrat ten formular

neco jsem tedy zkousel a nedela to tedy co bych si predstavoal predstavuji si, ze mam slupec cisel rostouci (nemusi jit po sobe 22 23 24 25 ->ale muze to byt 22 25 30 31 ale vzdy to bude vzrustajici)

a toto cislo by se mi zkopirovalo do mista kde je ramecek a nasledne to vytisklo (je nastavena tiskova oblast na oblast formulare)

momentalne se mi podarilo to makro asi uplne nejak rozbit protoze prestalo delat cokoliv :-)

aktualni stav makra

Kód: Vybrat vše

Sub tisk_souboru()
Dim i As Integer

Sheets("List1").Select
If Range("C1") <> "" Then
    For i = 2 To 10 'poslední řádek
        Range("B1") = Range("B" & i)
        Range("B" & i).Select
        ActiveSheet.Copy
        Range("B1").Select
        ActiveSheet.Paste
        ActiveWindow.SelectedSheets.PrintOut Copies:=1
    Next
End If
End Sub

ten max bunek budu chtit udelat promenlivy a co jsem koukal na to co jsi mi ukazoval tak tam asi maji byt "" a oznaceni sloupce pismenem a ne cislem ale tezko rici nejsem odbornik takze mozna to je rovnocene.

takze jsem vlastne nakonec udelal nejaky nesrovnalosti s kodem a makrem

Kód: Vybrat vše

Sub tisk_souboru()
Dim i As Integer

Sheets("List1").Select
If Range("C1") <> "" Then
    For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row 'poslední řádek
        Range("B1") = Range("B" & i)
        Range("B" & i).Select
        ActiveSheet.Copy
        Range("B1").Select
        ActiveSheet.Paste
        ActiveWindow.SelectedSheets.PrintOut Copies:=1
    Next
End If
End Sub

takze ted uz to jakz takz funguje az na otvirani miliony sesitu (pro kazdou zmenu novej) a take to ze pro dalsi uz to do bunky nezkopiruje obsah ale Cells(Rows.Count, 2).End(xlUp)

[Azuzula]

1. podmínka je že když není C1 prázdná tak se spustí makro, takže tam něco musí být, cokoliv. Nevím jestli je to nutné.
2. Nevidím důvod proč do makra dávat copy/paste - vždyť Range("B1") = Range("B" & i) je v podstatě to samé (zapisuje jen obsah buňky bez formátování a místo vzorce jen výsledek). Tidíž do buňky B1 zapíše obsah buňky B2, po otočení cyklu B3 do B1, B4 do B1 atd. až do poslední buňky.

Nic víc to makro neumí a v tom tvým sešitu ani nevím co víc by mělo dělat. Chtělo by to "ostrý" sešit, klidně se smyšlenými daty.

takze ted uz to jakz takz funguje az na otvirani miliony sesitu (pro kazdou zmenu novej) a take to ze pro dalsi uz to do bunky nezkopiruje obsah ale Cells(Rows.Count, 2).End(xlUp)

Tohle teda už nepobírám ani já

[Petrrr]

no co jsem zjistil tak to v tu chvili nebere jako prikaz ale jako text (coz se u nekterych prikazu stava, ackoliv jsem teda nikde na forku neprisel proc, pouze nejaky prikaz jiny co dela to same, kterej uz zapisy nedelal)

1) jj na to jsem pak prisel jen jsem nenahral novy soubor
2) to je mozne mou neznalosti
- ma to delat pouze toto :) navic by tam byl max ten formular co podle tech cisel nacte data a pak je treba vytisknout ostatni veci tam mam reseny funkcemi, ktere aspon chapu v tom VBA se docela casto ztracim :(


super tak uz to dela co ma tak snad to bude OK :)

Kód: Vybrat vše

Sub tisk_souboru()
Dim i As Integer

Sheets("FXXX_Petr").Select
If Range("M2") <> "" Then
    For i = 3 To Cells(Rows.Count, 12).End(xlUp).Row 'poslední řádek
        Range("L2") = Range("L" & i)
        ActiveWindow.SelectedSheets.PrintOut Copies:=1
    Next
End If
End Sub


konecny kod kdyby nekdo chtel k inspiraci moc dekuji za pomoc
opravdu my slo jen o toto abych dokazal vice veci poslat do tisku pokud mozno bez moznosti ze na neco zapomenu a pokud mozno rychle za sebou aby mi mezi to neco neposlal nekdo jiny :) jest jendou diky moc