Stránka 1 z 2
Makro kopírování plus doplnění
Napsal: 26 kvě 2013 23:01
od vencaa01
Dobrý den,
mám na Vás prosbu, potřeboval bych pomoci s makrem v souboru v příloze. Tedy jde o to, že do listu sumář bych potřeboval kopírovat hodnoty z ostatních listů, pokud ve sloupci I v jakém koly listu zadám hodnotu vyšší než 0 tak se překopíruje ten řádek u kterého je zadaná hodnota vyšší než 0 do listu sumář hodnoty ze sloupce B, H, I a J. Dále bych potřeboval, aby to fungovalo i tehdy pokud přidám další listy. A pokud by to bylo možné po vložení nového listu, aby se automaticky vložil sloupec I aj. I-zadávání kusů a J-jako výpočtový jak je vidět v listu 2. A poslední aby v listu Sumář byl stále na konci řádek kde, bude napsáno Cena Celkem, kde bude sčítaná hodnota kompletního sloupce D. Děkuji za případnou pomoc.
Re: Makro kopírování plus doplnění
Napsal: 01 čer 2013 10:08
od vencaa01
Dobrý den, pro doplnění kopírování se mi povedlo, ale neumím to udělat do celého listu, ale pouze do listů zvlášť viz. příloha.
Re: Makro kopírování plus doplnění
Napsal: 01 čer 2013 13:11
od cmuch
Trochu jsem to makro poupravil. Bude chodit na každém listu i nově přidaném.
Vlož ho ThisWorkBook
Kód: Vybrat vše
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim prac, slprac As Variant
Dim rprac, radek As Long
'Nastaveni
prac = "Sumáø" ' Název Listu do ktereho se ma kopírovat
slprac = 9 ' Sloupec co se má kontrolvat , 1=A
rprac = Target.Row ' Radek na kterem probehla zmena
' Neprovadej na listu do ktereho se ma kopirovat
If ActiveSheet.Name = prac Then Exit Sub
'Tichy rezim
Application.ScreenUpdating = False
' Proved kdyz je zmena ve sloupci
If Target.Column = slprac Then
' kontrola zda se ma kopirovat
If Cells(rprac, slprac).Value > 0 Then
Application.EnableEvents = False
'Najít první volný øádek na listu a vlozit
radek = Sheets(prac).Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveSheet.Rows(rprac).Copy Destination:=Worksheets(prac).Rows(radek)
Application.EnableEvents = True
End If
End If
'Tichy rezim vypnout
Application.ScreenUpdating = True
End Sub
Re: Makro kopírování plus doplnění
Napsal: 02 čer 2013 21:58
od vencaa01
Děkuji jo to mi dost pomohlo. Jen bych se rád zeptal je možné nějak udělat, aby když tam vložím nový list se automaticky doplnil sloupec I a J to je počet kusů a cena celkem. Jde oto, že tam bude cca 100 listů a do každého by se to muselo dodělávat zvlášť. Díky z pomoc.
Re: Makro kopírování plus doplnění
Napsal: 03 čer 2013 11:43
od cmuch
Do ThisWorkBook dopln
Kód: Vybrat vše
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name = "Sumář" Then Exit Sub 'neprovadej na listu "Sumar"
If Range("I2") = "" Then 'kdyz nic neni v I2 dopln
Range("I2").FormulaR1C1 = "Kusů"
Range("J2").FormulaR1C1 = "Cena Celkem"
Range("J4").FormulaR1C1 = "=IF(RC[-2]="""","""",RC[-2]*RC[-1])" '=KDYŽ(H4="";"";H4*I4)
Range("J4").AutoFill Destination:=Range("J4:J1000"), Type:=xlFillDefault 'vzorec pro preddef.oblast
End If
End Sub
Nevím zda je to přesně ono, ale když tak stačí upravit makro mezi IF ..THEN
Re: Makro kopírování plus doplnění
Napsal: 03 čer 2013 13:13
od vencaa01
Děkuji, Vím, že jsem asi už otravný, ale jsem dosti bezradný prosím ještě o jednu pomoc. V příloze přidávám můj předpracovaný soubor a přidávám ještě jeden od kud kopíruji list. A teď o co mi jde. V souboru sumář v listu sumáš jsem si udělal makro aby se mi vždy přidal řádek když tam něco nakopíruji jako podmínku používám sloupec L to potřebuji na to, že potřebuji pořád sčítat částky, které se mi nam nakopírují no a do listu pro celí sešit i pro nově přidané položky jsem vložil příkaz
ActiveSheet.Rows(rprac).Range("A" & Target.Row & ":J" & Target.Row).Copy Destination:=Worksheets(prac).Rows(radek) aby se nokopírovali buňky pouze od A do J bohužel to funguje že to nakopíruje uplně jiný řádek než ten v kterém udělám tu změnu. Ješte bych Vás požádal o radu s formátováním. Aby když vložím nový list ty přidané iformace se i vložily do ohraničení a formát čísla byl bez 10ných míst. Jo ještě bych se chtěl zeptat z jakého důvodu když vložím noví list se mi do listu sumář překopírují nesmysli z nově vloženého listu Děkuji moc za ochotu. Pokud budete chtít mohu se s Vámi i nějakým spůsobem vyrovnat. Díky moc.
--- Doplnění předchozího příspěvku (03 Čer 2013 13:22) ---
Omlouvám se, že Vás takle využívám, ale je to k usnadnění práce a dost. Původně mám program ceníky který fungoval výtečně do doby něž mi obchodní partneři nezačali posílat aktualizace v exelu. Tento program umí exportovat poze databázové soubory. takže nyní mám cca 100 souborů exel v každém jeden list kde různě mezi nimi překlikávám a kopíruji, abych docílil výsledné ceny zařízení. Ještě jednou Vám děkuji za tuto pomoc.
Re: Makro kopírování plus doplnění
Napsal: 03 čer 2013 18:09
od cmuch
Koukněte do přílohy. není tam to celkem celkově v listu Sumář (zatím).
Re: Makro kopírování plus doplnění
Napsal: 04 čer 2013 13:31
od vencaa01
Děkuji moc, vše je o.k. jen bych se chtěl zeptat kde mám chybu v tom když zadám v nějakém listu kusy nakopíruje se mi to do listu sumář, ale již se mi tam nepřidá řádek. nějak nemohu najít, kde je chyba. Makro je k tomu napsané jen v listu sumář. Díky moc a jsem velkým dlužníkem. Kdyby jste petřeboval poradit nebo napsat program do PLC jsem k dispozici to umím dobře

)
Re: Makro kopírování plus doplnění
Napsal: 05 čer 2013 06:06
od cmuch
Programovat PLC také umím.
Chyba je v tom, že to makro se vyvolá jen po změně na listu,
ale toto je zakázané v tom hlavním makru tímto Application.EnableEvents = False
když se toto odstraní a makro poupraví tak to nakopíruje ty prázdné buňky tak jak je v tom makru.
Nevím co tím zamýšlíš, ale toto by splnilo i to kdyby si zdvojil to kopírování z hlavního makra a pak smazal jen text.
Když tak popiš proč to tam máš.
Re: Makro kopírování plus doplnění
Napsal: 05 čer 2013 09:34
od vencaa01
Děkuji. Potřebuji to kuli tomu abych tam pod to mohl vložet řádek celkem. a všechny hodnoty co tam nakopíruji mi to bude sčítat. Jelikož v makru celkem je dáno, že hledá prázdný řádek kam vložit tak mi to tam vždy nakopíruje a posune o jedno níž tím docílím, že bude stále volný řádek na kopírování mezi součtem a hlavičkou tudíš mi to nikdy nenakopíruje pod konečný řádek celkem. Asi na to jdu příliš složitě co?
--- Doplnění předchozího příspěvku (05 Čer 2013 09:35) ---
Mohu se zeptat na nějakou literaturu z které se dá makro v exelu trochu naučit musím se přiznat, že v tom dost plavu.
Re: Makro kopírování plus doplnění
Napsal: 05 čer 2013 13:14
od cmuch
Kniha / knihy
Na ten prázdný řádek zkus použít toto.
Nahraď v makru v ThisWorkBook
Kód: Vybrat vše
Application.EnableEvents = False
'Najít první volný řádek na listu a vlozit
radek = Sheets(prac).Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveSheet.Range("A" & Target.Row & ":J" & Target.Row).Copy Destination:=Worksheets(prac).Range("A" & radek & ":J" & radek)
ActiveSheet.Range("A" & Target.Row & ":J" & Target.Row).Copy Destination:=Worksheets(prac).Range("A" & radek + 1 & ":J" & radek + 1)
Sheets(prac).Range("A" & radek + 1 & ":J" & radek + 1).ClearContents
Application.EnableEvents = True
Re: Makro kopírování plus doplnění
Napsal: 05 čer 2013 14:31
od vencaa01
Ahoj nakonec jsem to udělal takto a je to co potřebuji.
Kód: Vybrat vše
Application.EnableEvents = False
'Najít první volný řádek na listu a vlozit
radek = Sheets(prac).Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveSheet.Range("A" & Target.Row & ":J" & Target.Row).Copy Destination:=Worksheets(prac).Range("A" & radek & ":J" & radek)
Sheets(prac).Range("A" & Target.Row & ":J" & Target.Row).Insert shift:=xlDown
Application.CutCopyMode = False
Sheets(prac).Range("A" & Target.Row & ":J" & Target.Row).ClearContents
Application.EnableEvents = True