VBA makro- kopirovani s podminkou

[Axinka]

KOPIROVANI S PODMINKOU.xls

(27 KiB) Staženo 36 x

Ahoj vsem,

muzete mi nekdo poradit jak sestavit v excelu makro na kopirovani vsech radku z VZOR do noveho listu s podminkou, ze hodnota ve 4. sloupci musi byt >0?
Range (B3:G45) z listu VZOR do noveho listu.

Predem moc diky za pomoc
Axi

[Reklama]

[cmuch]

Vítej na PC-Help

Makro zkopíruje hodnoty z řádku na nový list.

Alt+F8 - makro "Kopie"

[Axinka]

Ahoj a moc díky to pomohlo,

ještě ale řeším zapeklitou věc- v původní tabulce je SUBTOTAL na mezisoučty a ten bych potřebovala i když hodnoty přes makro s podmínkou překopíruji do dalšího listu ALE ,,kategorie,, pod které subtotal potřebuji vložit nejsou nijak systematicky rozlišené (jenom barvou ve sloupci A a ta je taky ,,náhodná,,). Dá se toto nějak vyřešit? tzn. jak zadat kdy a kam se má subtotal vložit, pokud bych to řešila makrem?

Předem moc díky za pomoc
Axi

[cmuch]

Co třeba takto,
nahraď část For tímto

Kód: Vybrat vše

For rprac = 3 To radek
  'Najít první volný řádek na listu sl B a vlozit
  radekn = Sheets(newshnm).Cells(Rows.Count, 2).End(xlUp).Row + 1
  ' Proved kdyz je zmena ve sloupci
  If Sheets(pracsh).Cells(rprac, slprac).Value > 0 Then
   
    'vlozit
    Worksheets(pracsh).Rows(rprac).Copy
   
    Worksheets(newshnm).Rows(radekn & ":" & radekn).PasteSpecial Paste:=xlPasteValues, _
      Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A1").Select
   
   ElseIf Sheets(pracsh).Cells(rprac, 2).Value = "Subtotal" Then
   
    Sheets(newshnm).Cells(radekn, 2).Value = Sheets(pracsh).Cells(rprac, 2).Value
  End If
Next rprac

[Axinka]

Ahoj,

diky moc, to funguje. Jeste resim posledni problem- jak nastavit, aby kazdy subtotal ve sloupci G zobrazil mezisoucet polozek v radsich ,,nad subtotal,, a zaroven mezi podlednim subtotalem.

Diky za radu

[cmuch]

Nahraď to původní makro tímto:

Kód: Vybrat vše

Sub Kopie()

Dim pracsh, slprac, newshnm As Variant
Dim rprac, radek, radekn As Long
Dim startRow As Integer
Dim startCell As Range, endCell As Range

'Tichy rezim
Application.ScreenUpdating = False

'Nastaveni
pracsh = "VZOR"  ' Název Listu ze ktereho se ma kopirovat
slprac = 4      ' Sloupec co se má kontrolvat , 1=A
startRow = 2    ' radek od ktereho se bude pocitat

'Najít posledni øádek na listu ve sl B
radek = Sheets(pracsh).Cells(Rows.Count, 2).End(xlUp).Row
' vytvor list a zjisti jmeno
Sheets.Add After:=Sheets(Sheets.Count)
newshnm = ActiveSheet.Name

For rprac = 3 To radek
  'Najít první volný øádek na listu sl B a vlozit
  radekn = Sheets(newshnm).Cells(Rows.Count, 2).End(xlUp).Row + 1
  ' Proved kdyz je zmena ve sloupci
  If Sheets(pracsh).Cells(rprac, slprac).Value > 0 Then
   
    'vlozit
    Worksheets(pracsh).Rows(rprac).Copy
   
    Worksheets(newshnm).Rows(radekn & ":" & radekn).PasteSpecial Paste:=xlPasteValues, _
      Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Range("A1").Select
   
   ElseIf Sheets(pracsh).Cells(rprac, 2).Value = "Subtotal" Then
    ' vepsani subtotal
    Sheets(newshnm).Cells(radekn, 2).Value = Sheets(pracsh).Cells(rprac, 2).Value
    ' soucet bunek
    Set startCell = Sheets(newshnm).Cells(startRow, 7)
    Set endCell = Sheets(newshnm).Cells(radekn, 7).Offset(-1, 0)
    Sheets(newshnm).Cells(radekn, 7).Formula = "=SUM(" & startCell.Address & ":" & endCell.Address & ")"
    startRow = radekn + 1
  End If
Next rprac

Sheets(pracsh).Select
Application.CutCopyMode = False
Range("A1").Select

'Tichy rezim vypnout
Application.ScreenUpdating = True

Set startCell = Nothing
Set endCell = Nothing

End Sub

[Axinka]

Ahoj, diky moc. Pracovala jsem s tim dal a nejak se zamotavam. Myslim, ze se cely muj problem da vyresit urcite nejak lip, nez myslim. Co konkretne chci udelat- komplet cela tabulka v listu VZOR se ma nakopirovat na novy list (vcetne formatu a vzorcu v kazde bunce jak je v puvodnim VZOR) a v nove tabulce na List 1 potrebuji jenom odstranit radky, ktere budou mit ve sloupci 4 hodnotu rovne= 0.
Da se to vyresit jednodussim makrem? Ja uz se v tom totiz zamotala uplne.

Moc diky za pomoc

[cmuch]

Ještě odladím trochu makro, ale až o víkendu.
Pokud někdo neodpoví dříve.

[Axinka]

Diky moc!

[Axinka]

Ahoj, jenom jsem chtela doplnit info, ze v tom sesitu VZOR co jsem pripojila jako posledni se na konci tabulky nachazeji radky se soucty (ktere jsem tam predim nemela), pak jsou tam radky na poznamky, ktere bych taky potrebovala kopirovat.

Moc diky predem milionkrat
Axi

[cmuch]

Upravil jsem vzorec pro subtotaly a předělal makro.

Koukni na to.


// upraveno makro (skrývá řádky kde je subtotal 0kč)

[Axinka]

Perfektni, muzes pls uz jenom nastavit,aby se pri kopirovani vymazaly ty ,,Subtotal,, ktere maji ve sloupci hodnotu 0kč?
Diky