Excel - správné naprogramování makra pro neprogramátora Vyřešeno

[Jumbo]

Ahoj,

V práci velmi často pracuji s tabulkami, ve kterých jsou zadaná data pro tiskárnu, kde se personifikují plastové karty
(tato tiskárna je velmi vyspělý stroj, zvládá potisknout až 33 tisíc karet za hodinu včetně vlastní kontroly kvality tisku a správného natištění dat), běžně na ní vyrábíme zakázky o půl milionu karet. Ale o toto nejde, dostáváme data v Excelu, NAPŘÍKLAD pro sortu BSH, která obsahuje 60.000 řádků ve 5ti sloupcích s daty. Já tyto tabulky ručně upravuji pro vytváření etiket ve Wordu, pro krabičky kam dáváme potištěné karty po 250-ti kusech, kdy potřebuji z tabulky použít pouze data pro první a 250tou kartu (první a poslední z krabičky) a to tak, že potřebuji zachovat v datech vždy první kartu, pak smazat 248 řádků, 250 řádek zachovat, a ten přesunout do druhého sloupce k první kartě, pak smazat vzniklý prázdný řádek a celé opět opakovat. Nevím jestli to popisuji nějak pochopitelně, proto přikládám obrázky z této činnosti, kterou velmi potřebuji zautomatizovat - zabírá to ruční prací neskuteně mnoho času.
Velmi proto prosím o pomoc s vytvořením a používáním makra (zkoušel jsem to, ale nedaří se)

[Reklama]

[Jumbo]

Jen abych upřesnil, já to makro udělal přes záznam makra, jenže nedělá přesně co potřebuji, to bych musel ručně projet celý list aby makro dělalo co potřebuji. Protože, když makro naučím udělat to pouze pro první řádku a spustím ho, udělá první řádku. Ale když ho chci spustit od další řádky, opět předělá pouze tu první. A s tím si nevím rady a programovacími schopnostmi opravdu neoplývám

Díky

[mike007]

Promiň za to rejpnutí, ale nedá mi to se nezeptat.
Vy v práci nemáte IT oddělení?

[Jumbo]

To se neomlouvej , opravdu nemáme, jsme malá firma... ve firmě je 7 počítačů (plus 3 v perso mašině ) zapojených v lance se servrem kde jsou mirrorovaný harddisky... Nic složitýho... Ve firmě ani nic nevyvíjíme, pouze vyrábíme..

//Není potřeba citovat poslední příspěvek. Upraveno.
//mike007

[Jumbo]

Tak se s tím zkouším prát. Makro mi funguje ale jenom tak, že musím stále ručně dopomáhat. Klikat na správnou řádku, poté spustit makro - 3 repetetivní kroky. .. To je hezký, už to by ušetřilo čas, ale ne tak jak si představuji. Jak toto donutit pracovat automaticky na celý list??? Nebo opravdu musím nahrát makro krok za krokem pro celý sešit a to poté aplikovat???
Díky jestli někdo poradí...

[atari]

Moc programovat neumím, ale tohle jsem udělal, Snad jsem to dobře pochopil.
Do promenne pocetradku je potreba zadat pocet obsazenych rádků. Lze to i řešit funkci count přes VBA. Nejsou tam ošetřeny chybové stavy a výsledky. Hlavně to, když pocetradku nebude přesně násobek hodnoty 250.

Sub Makro()
Dim krok As Integer
Dim pocetradku As Long

Application.ScreenUpdating = False
krok = 248
pocetradku = 60000

For i = 1 To pocetradku / (krok + 2)
Range(Cells(i + 1, 1), Cells(i + krok, 16384)).Select
Selection.Delete Shift:=xlUp
Cells(i, 2) = Cells(i + 1, 1)
Range(Cells(i + 1, 1), Cells(i + 1, 16384)).Select
Selection.Delete Shift:=xlUp
Next i

Application.ScreenUpdating = True
End Sub

Je to uděláno pro data prvního sloupce. Předělat to na další sloupce je jednoduché.
Cells(3,1) znamená že 3 je třetí řádek a 1 je první sloupec. Takže makro překopírujete a 1 změníte na 3, a máte to na třetí sloupec, atd

[Jumbo]

2Atari:

na to, že nejste programátor, tak se Vám klaním , toto bych opravdu nezvládl. Je to perfektní, dělá to přesně co má!!! Stačí jen doupravit podle potřeby (např pro 25000 řádek)a to takto:


Sub Makro()
Dim krok As Integer
Dim pocetradku As Long

Application.ScreenUpdating = False
krok = 248
pocetradku = 25000

For i = 1 To pocetradku / (krok + 2)
Range(Cells(i + 1, 1), Cells(i + krok, 248)).Select
Selection.Delete Shift:=xlUp
Cells(i, 2) = Cells(i + 1, 1)
Range(Cells(i + 1, 1), Cells(i + 1, 248)).Select
Selection.Delete Shift:=xlUp
Next i

Application.ScreenUpdating = True
End Sub


Nejprve to nefungovalo, tak jsem na to laicky koukl a napadlo mě, že je asi chyba v tom 16384, nebo co jste to tam použil za číslo, nahradil jsem to 248 a funguje to!!! Ještě až ze mne opadne tohle nadšení, znovu si projedu kontrolou, zdali to udělalo úplně přesně co potřebuji (nedošlo k chybě), ale vlastně můžu už teď říct že to šlape 100%, mockrát děkuji!!!

[mike007]

Je vidět, že se s makry už někdy setkal :)

Upravil jsem jeho makro tak, aby dělalo to co má.

Sub Makro()
Dim krok As Integer
Dim pocetradku As Long

Application.ScreenUpdating = False

krok = 248
pocetradku = WorksheetFunction.CountA(Range("A1").EntireColumn)


For i = 1 To pocetradku / (krok + 2)
Range(Cells(i + 1, 1), Cells(i + krok, 3)).Select
Selection.Delete Shift:=xlUp
Cells(i, 2) = Cells(i + 1, 1)
Range(Cells(i + 1, 1), Cells(i + 1, 3)).Select
Selection.Delete Shift:=xlUp

Next i

ActiveCell.Offset(0, 1).Select
ActiveCell = Range("A65536").End(xlUp)
ActiveCell.Offset(1, -1).Select
Rows(ActiveCell.Row & ":65536").Select
Selection.Delete Shift:=xlUp
Range("A1").Select

Application.ScreenUpdating = True
End Sub

[Jumbo]

2 Mike Bond:

Vaše makro funguje ještě lépe než od Atari. Je především mnohem rychlejší a super, že se nemusí nic nastavovat. Krásná práce! Akorát to na poslední řádku do sloupce B, kde už nic být nemá vypíše poslední řádku ze sloupce A.

[mike007]

jj, taky jsem teď na to přišel. Když je počet plných řádků dělitelný 250, tak tam tohle zůstane
Už pracuju na updatu.

[mike007]

Kdyby mě viděl můj zaměstnavatel, tak bych asi dostal padáka. Vůbec se nevěnuju práci

Tak tady to máš.

Sub Makro()

Dim krok As Integer
Dim pocetradku As Long

Application.ScreenUpdating = False

krok = 248
pocetradku = WorksheetFunction.CountA(Range("A1").EntireColumn)


For i = 1 To pocetradku / (krok + 2)
Range(Cells(i + 1, 1), Cells(i + krok, 3)).Select
Selection.Delete Shift:=xlUp
Cells(i, 2) = Cells(i + 1, 1)
Range(Cells(i + 1, 1), Cells(i + 1, 3)).Select
Selection.Delete Shift:=xlUp

Next i

ActiveCell.Offset(0, 1).Select
ActiveCell = Range("A65536").End(xlUp)
ActiveCell.Offset(1, -1).Select
Rows(ActiveCell.Row & ":65536").Select
Selection.Delete Shift:=xlUp
Range("A1").Select

Range("A65536").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Rows(ActiveCell.Row & ":65536").Select
Selection.Delete Shift:=xlUp
Range("A1").Select

Application.ScreenUpdating = True
End Sub

Vyzkoušej a dej vědět.

[Jumbo]

Tak tohle je vážně už 100% bez chybičky!!! Luxus pane! Mockrát děkuji!!! Toho času co to ušetří, jupíííí .
Kdybych chtěl ještě aby to pak samo udělalo tabulku pro etikety, to bych chtěl už moc, že? Je tam 6 sloupců, přičemž 2 jsou co teď makro dělá, 2 jsou neměnný a 2 jsou v podstatě počty řádek (jeden klasický, druhý se speciálním formátem čísel, např. 10,002,001) a samozřejmě v první řádce hlavička aby Word měl z čeho poznat data.

Ještě jednou mockrát děkuji Miku Bonde!!!!