Makro kopírování plus doplnění Vyřešeno

[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.

[Reklama]

[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.

[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


[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.

[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

[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.

[cmuch]

Koukněte do přílohy. není tam to celkem celkově v listu Sumář (zatím).

[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 )

[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áš.

[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.

[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

[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