MS Excel help - kopírování jen určitých řádků na další list

[wASQ]

Zdravím, ahoj. Opět se obracím o pomoc na vaše forum, snad mi tu někdo pomůže.. Potřeboval bych buďto skript, nebo formuli na nakopírování pouze červeně označených částí sešitu do jiného - v tom samém souboru (viz obrázek). Nedokázal jsem se s tím poprat... Please help

PS: Údajů v tabulce je mnohem více, tohle je jen názorná část

[cernohous13]

Ahoj, na liště listů zkopíruj (pravým) celý list do nového umístění
ve sloupci řádků označ při CTRL vše nepotřebné
označené řádky smažeš CTRL+-

je to primitivní, ale funkční

Pokud toho je moc a nezvládnutelné - zkusím ti sehnat odborníka

[wASQ]

No při počtu cc 1000 rádků a nutnosti této úpravy každý měsíc je to malinko zdlouhavý proces, proto sháním nějaký zrychlovač. Takhle bych si poradil taky, nejsem zas úplně mimo...

[cernohous13]

seřadit data podle sloupce C
odstranit nepotřebné
seřadit podle B

když vydržíš, zkusím kontaktovat odborníka

[cernohous13]

našel jsem jen tento kontakt alojz.lacko[zavinac]quick.cz - zkus mu napsat

[wASQ]

Díky, už jsem ho kontaktoval

[cernohous13]

Dej info jak se zadařilo

[AL1212]

wASQ, pozerám na to, nie je to nič zložité. Asi by som na to napísal nejaké makro, ale radšej by som dostal priamo vzorok excelovského súboru, aby som si nemusel vymýšľať názvy listov atď., t.j. aby to bolo eventuálne rovno aplikovateľné a nemuseli sa v kóde robiť dodatočné úpravy. Mohol by ste mi poslať kópiu toho súboru do mailu?

[wASQ]

Řešíme poštou...

[AL1212]

čakám na súbor, ktorý bude mať štruktúrované dáta - zmienil som, že to, čo ste mi poslal, je nejaké rozsypané, každopádne, ten kód by mal vyzerať nejak nasledovne (buď si ho vložte priamo do modulu v danom súbore, alebo niekam do osobného zošitu makier (v tom prípade sa ale pred spustením ubezpečiť, že je aktívny správny zošit - t.j. ten, v ktorom chcete to makro spustiť) - vyskúšajte a dajte vedieť:

Tak som sa popasoval i s tým rozsypaným čajom - toto by malo byť plne funkčné:

Option Explicit
Sub Vystup()

Dim i As Long, posl As Long

Application.ScreenUpdating = False

Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "vystup"
Sheets(1).Select
Cells.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
ActiveSheet.Name = "AUX"


Rows("1:1").Delete Shift:=xlUp
Cells.AutoFilter
ActiveSheet.Columns("A:H").AutoFilter Field:=1, Criteria1:="Celkem za"
Columns("B:D").Copy
Sheets("vystup").Select
ActiveSheet.Paste
Cells.EntireColumn.AutoFit
Rows("1:1").Delete Shift:=xlUp

For i = 1 To WorksheetFunction.CountA(Columns("A"))
If IsNumeric(Cells(i, 3)) And Len(Cells(i, 3)) > 0 Then
Cells(i, 1) = Cells(i, 1) & Cells(i, 2)
Cells(i, 2) = Cells(i, 3)
Cells(i, 3).ClearContents
End If

Cells(i, 1) = Right(Cells(i, 1), Len(Cells(i, 1)) - InStr(Cells(i, 1), "-"))
Next i

Sheets("List1").Select
Range("A1").End(xlDown).Select
posl = Selection.Row
Range(Cells(posl, 1), Cells(posl, 2)).Copy
Sheets("vystup").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste

Application.DisplayAlerts = False
Sheets("AUX").Delete
Range("A1").Select
Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub

[wASQ]

Poslední verze, co mám od Vás v mailu funguje báječně. Takže i tady ještě jednou díky moc!

[AL1212]

Rado sa stalo, v prípade, že ten súbor budete používať (aby ste to makro mali priamo v ňom), tak pri spracovaní novej sady dát túto nakopírujte do listu 1 a pred spustením makra odstráňte list vystup, inak Vám to zakričí chybu - nie je to úplne tip ťop - pár bodiek v scripte by sa dalo ešte odstrániť a ošetriť ešte prípadné chyby, ale dá sa to i tak asi slušne používať, keby s tým bol nejaký problém, tak sa ozvite

[cernohous13]

AL1212 - díky za pomoc
můžeš mi dát pro podobné případy do SZ ještě nějaký kontakt na tebe? (ICQ, Skype)

[sudanec]

cernohousi, ak toho nebude vela, mozes kricat aj na mna (ked som bol maly som sa pisanim VBA pre excel chvilu zivil)
inak sa tesim, ze to este stale niekto robi tu je s VBAckarmi dost problem, nekonecne vela zakazok, ktore nikto nechce (teda ak by pan kolega nieco chcel, nech sa mi ozve a poriesime)

[cernohous13]

Díky za nabídku, je dobré to vědět