Přidat otázku mezi oblíbenéZasílat nové odpovědi e-mailem Excel VBA - vytvoření databáze

Zdravím Vás,

Mám prosbu, mám následující soubor s jedním makrem, které slouží k přidání člena do listu Přehled

Na toto Makro bych chtěl dále navázat funkci, která by celý tento nově vložený záznam(řádek) nakopírovala do příslušného listu, na základě podmínky, kdy by se ta Kategorie (M, Ž, JRI, JRY) shodovala s názvem listu. Samozřejmě nakopírování do prvního prázdného řádku v těch dalších listech.

Předem díky za ochotu/ nasměrování

Jsou zobrazeny jen nové odpovědi. Zobrazit všechny
Předmět Autor Datum
se samotným kopírováním a výběrem listu nemám ani tak problém, spíše mi dělá problém definovat buňky…
Thomasino 10.09.2019 09:17
Thomasino
Za prvé - to nalezení prvního prázdného řádku se dá efektně zkrátit na jediný příkaz (bez cyklu): P…
MachR55 10.09.2019 09:43
MachR55
Ahoj prosimtě mám prosbu...... kopírovací makro mezi listy jsem nahrál pomocí funkce nahrát makro, z…
Thomasino 11.09.2019 07:19
Thomasino
... chyba je v Range(x).Select ... Samozřejmě, protože v "x" máš číslo (prvního prázdného řádku), n… nový
MachR55 11.09.2019 08:33
MachR55
Sub Kopirovani() Sheets("Přehled").Select Application.ScreenUpdating = False ' zrychluje makro y = R… nový
Thomasino 11.09.2019 10:15
Thomasino
Když se tak na to dívám, tak v tom větvení (které silně doporučuji předělat na Select Case) bych si… nový
MachR55 11.09.2019 10:31
MachR55
edit funguje jen jsem v každém IFU za každé ActiveSheet.Paste přidal Sheets("Přehled").Select nový
Thomasino 11.09.2019 10:31
Thomasino
Problém číslo jedna vyřešen uprava kodu: Rows(i).Select Selection.Copy Sheets("KKY").Select x = R…
Thomasino 11.09.2019 08:08
Thomasino
obávam sa že Ti to nepôjde z viacerých dôvodov: 1 pokiaľ budeš v cykle "Select"-ovať hárok, potrebuj… nový
robert13 11.09.2019 10:33
robert13
Zkus tohte nový
robert13 11.09.2019 11:42
robert13
Tak pro zajímavost posílám doposud poslední finální funkční verzi, ten FOR mi funguje jak má a vždy… nový
Thomasino 11.09.2019 10:56
Thomasino
No, když Ti to takhle stačí, proč ne... Jsou tam ale věci, které bych takhle určitě nenechal (o něče… nový
MachR55 11.09.2019 11:35
MachR55
Oups, vidím, že som poslal niečo, medzičím sa situácia vyvinula inak... Ale môžeš aspoň čerpať inšpi… nový
robert13 11.09.2019 11:44
robert13
díky všem za poznatky, ve volném čase udělám efektivnější kód :) btw. já jen zpracoval dokument, s… nový
Thomasino 11.09.2019 11:46
Thomasino
No jo, mazanie celého cieľa a jeho kompletné znovunaplnenie v určitých prípadoch má význam. Postupné… nový
robert13 11.09.2019 12:13
robert13
S tím přidáním člena si pohraju dále, o tom funkčním formuláři jsem v podstatě nevěděl, takže naštud… nový
Thomasino 11.09.2019 13:10
Thomasino
Nejprve bych na začátku zavedl zkratku na hlavní list "Přehled", abych na něj mohl snáze odkazovat:… nový
MachR55 11.09.2019 13:48
MachR55
Ďalšia čiastková pripomienka k modulu 1: Nemusíš najprv načítavať InputBoxy do premenných a v ďalšom… nový
robert13 11.09.2019 14:43
robert13
Takže celý ale celičičký tvoj kód Sheets("Přehled").Select Application.ScreenUpdating = False ' zr… nový
robert13 11.09.2019 15:47
robert13
pokiaľ tam však budeš mať skupinu, ktorá nemá svoj hárok alebo bude v hárku Přehled preklep v skupin… nový
robert13 11.09.2019 15:50
robert13
Upravil som Ti Modul 2 - vložil som Ti tam makro "Prenos" a dve tlačítka Skús si to spustiť - všetko… nový
robert13 11.09.2019 16:11
robert13
vysvetlenie prenosového výrazu v prílohe nový
robert13 11.09.2019 16:38
robert13
Tak tady máš ďalší stupienok vrátane kontroly existencie listu, vrátane minimalizácie kódu a s autom… nový
robert13 12.09.2019 08:56
robert13
Jako MachR55 zcela odpovědně prohlašuji, že přes Excel jsi SuperMachr! Fakt paráda... :beer: nový
MachR55 12.09.2019 08:15
MachR55
Já to až tak nevidím ale diky, ale jseš taky dobrej! :beer: nový
robert13 12.09.2019 08:57
robert13
Tak tu to máš vrátane vstupného formulára a pár úkonov naviac... K dokonalosti to má sakra ďaleko al… poslední
robert13 12.09.2019 11:01
robert13

Za prvé - to nalezení prvního prázdného řádku se dá efektně zkrátit na jediný příkaz (bez cyklu):

PrvniPrazdnyRadek = Range("A1").End(xlDown).Row + 1

A ty zadávané věci si přece můžeš prvně uložit do proměnné:

Zad_Jmeno = InputBox("Zadej Jméno:")
...

.. a pak je ukládat do buněk. Dále doporučuji vyhnout se konstrukcím ActiveCell+OFFSET, použij přímé adresování buněk CELL(řádek, sloupec):

Cell(PrvniPrazdnyRadek,1).Value = Zad_Jmeno
...

Ahoj prosimtě mám prosbu...... kopírovací makro mezi listy jsem nahrál pomocí funkce nahrát makro, znělo následovně:

sub makro_kopirovani()

Sheets("Přehled").Select
Rows("12:12").Select
Selection.Copy
Sheets("KKY").Select
Range("A4").Select
ActiveSheet.Paste

end sub

Snažil jsem se ho tedy aplikovat na můj případ:

Sub kopirovani()

Sheets("Přehled").Select

y = Range("B3").End(xlDown).Row ' PosledniZapsanyRadek

For i = y To 3 Step -1 ' uloží do i poslední zapsaný řádek , který nalezl jako y, a začně cyklus

    If Cells(i, 10) = "KKY" Then '10 je označení sloupce J -> rozeznává v jaké se hráč nachází skupině
    'MsgBox ("KKY")
    Rows(i).Select
    Selection.Copy
    Sheets("KKY").Select
    x = Range("B1").End(xlDown).Row + 1 ' PrvníPrázdnýŘádek
    Range(x).Select
    ActiveSheet.Paste
    ElseIf Cells(i, 10) = "ZCI" Then
    MsgBox ("ZCI")
    ElseIf Cells(i, 10) = "MZKY" Then
    MsgBox ("MZKY")
    ElseIf Cells(i, 10) = "JAROŠOV" Then
    MsgBox ("JAROŠOV")
    ElseIf Cells(i, 10) = "PŘÍPRAVKA" Then
    MsgBox ("PŘÍPRAVKA")
    ElseIf Cells(i, 10) = "JKY" Then
    MsgBox ("JKY")
    ElseIf Cells(i, 10) = "ZKY" Then
    MsgBox ("ZKY")
    ElseIf Cells(i, 10) = "JUNI" Then
    MsgBox ("JUNI")
    ElseIf Cells(i, 10) = "" Then
    MsgBox ("Prázdné")
    End If
Next i

End Sub

a mám dva problémy: ten první je, že mi to nekopíruje, chyba je v Range(x).Select, kdy mi to hodí error 1004: method range of object _ global failed
druhý "nedostatek" je ten, že bych potřeboval, jak mi to vybírá Rows(i).Select, tak bych ten selektovaný řádek potřeboval BEZ první buňky zleva

věděl by si někdo prosím rady? díky

... chyba je v Range(x).Select ...

Samozřejmě, protože v "x" máš číslo (prvního prázdného řádku), nikoli objekt typu Range:

x = Range("B1").End(xlDown).Row + 1 ' PrvníPrázdnýŘádek

Takže zkus

Cells(x,2).Select

... jak mi to vybírá Rows(i).Select, tak bych ten selektovaný řádek potřeboval BEZ první buňky zleva...

A proč vůbec vybíráš celý řádek? To tam máš tolik údajů? Určitě ne, že. Takže zkus vybrat oblast od druhého třeba do 20. sloupce:

Range(Cells(x,2),Cells(x,20)).Select

Anebo rovnou bez Selektu:

Range(Cells(x,2),Cells(x,20)).Copy

Dále - místo té spousty ElseIfů využij strukturu Select Case.

A ještě jeden tip - učit se VBA přes záznamy maker není až tak špatné, ale ty makra jsou často hodně nepřehledné a zabordelené, takže je vhodné je trochu pročistit a učesat. Například ten tvůj záznam uvedený na začátku dotazu (sub makro_kopirovani) lze upravit a zjednodušit několika možnými způsoby:

sub makro_kopirovani_uprava1()
  Sheets("Přehled").Rows("12:12").Copy
  Sheets("KKY").Activate
  Range("A4").Select
  ActiveSheet.Paste
end sub

sub makro_kopirovani_uprava2()
  Worksheets("Přehled").Rows("12:12").Copy Destination:=Worksheets("KKY").Range("A4")
end sub

Edit: Než jsem odeslal odpověď, koukám, že už jsi na ten první bod přišel...

Sub Kopirovani()

Sheets("Přehled").Select

Application.ScreenUpdating = False ' zrychluje makro

y = Range("B3").End(xlDown).Row ' PosledniZapsanyRadek

For i = y To 3 Step -1 ' uloží do i poslední zapsaný řádek , který nalezl jako y, a začně cyklus, začíná od třetího řádku dolů

    If Cells(i, 10) = "KKY" Then '10 je označení sloupce J -> rozeznává v jaké se hráč nachází skupině
         Range(Cells(i, 2), Cells(i, 11)).Copy
         Sheets("KKY").Select
         x = Range("B1").End(xlDown).Row + 1
         Cells(x, 2).Select
         ActiveSheet.Paste
    ElseIf Cells(i, 10) = "ZCI" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("ZCI").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).Select
        ActiveSheet.Paste
    ElseIf Cells(i, 10) = "MZKY" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("MZKY").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).Select
        ActiveSheet.Paste
    ElseIf Cells(i, 10) = "JAROŠOV" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("JAROŠOV").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).Select
        ActiveSheet.Paste
    ElseIf Cells(i, 10) = "PŘÍPRAVKY" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("PŘÍPRAVKY").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).Select
        ActiveSheet.Paste
    ElseIf Cells(i, 10) = "JKY" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("JKY").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).Select
        ActiveSheet.Paste
    ElseIf Cells(i, 10) = "ZKY" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("ZKY").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).Select
        ActiveSheet.Paste
    ElseIf Cells(i, 10) = "JUNI" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("JUNI").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).Select
        ActiveSheet.Paste
    ElseIf Cells(i, 10) = "" Then
    
    End If
Next i

Application.ScreenUpdating = True ' zrychluje makro

End Sub

díky za připomínky, místo row jsem tedy použil range a cells jak si radil a už kopíruju ty buňky jaké chci, nicméně kód uplně nefunguje, kopíruje pouze ty řádky, které mají shodný sloupec L jako uplně prvně nalezený záznam. přitom ani nenakopíruje všechny a občas se tam nějaký záznam vyskytl víckrát, asi to je způsobeno těma else if jak říkáš, budu muset hledat nějaké elegantnější řešení , naštuduju si ten case. ale doufal jsem že i ten elseif bude fungovat.....

Když se tak na to dívám, tak v tom větvení (které silně doporučuji předělat na Select Case) bych si pouze nastavil vhodné parametry a to kopírování provedl až nakonec ... ...
... :i: ... A když už jsem to začal předělávat, tak mi svitlo, že se vlastně můžeš kompletně obejít bez té haldy větví - . Nějak takhle:

Skupina = Cells(i, 10)
Range(Cells(i, 2), Cells(i, 11)).Copy
Sheets(Skupina).Select
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).Select
ActiveSheet.Paste
Sheets("Přehled").Select

Asi bys měl ještě ošetřit existenci listu s názvem v proměnné Skupina, prázdnou buňku, apod., resp. to můžeš kontrolovat při zadání na listu Přehled.

Problém číslo jedna vyřešen

uprava kodu:

    Rows(i).Select
    Selection.Copy
    Sheets("KKY").Select
    x = Range("B1").End(xlDown).Row + 1  ' PrvníPrázdnýŘádek
    Cells(x, 1).Select
    ActiveSheet.Paste

teď bych ještě potřeboval napravit ten druhý problém a to je to kopírování toho řádku bez té první buňky zleva

obávam sa že Ti to nepôjde z viacerých dôvodov:
1 pokiaľ budeš v cykle "Select"-ovať hárok, potrebuješ sa po prepnutí do cieľového hárka a zápise do jeho posledného riadka vrátiť späť do zdrojového hárka, čo nerobíš (dá sa vyriešiť kopírovaním bez selectu priamo do cieľa ako naznačil Machr)
2 neriešil by som ani cez If ani cez Select Case. Cieľovú adresu pre metódu Copy by som rovno skladal obsahom bunky v stĺpci J príslušného riadka (=cieľový hárok) a prvým voľným riadkom cieľa
3 nechápem tie skupiny, tvoj vzorový príklad nič takého nemá a mal si 4 cieľové hárky podľa kategórie
4 prepis by som uskutočňoval hneď po založení riadka v hárku Přehled. Cieľová adresa (ako píšem v bode 2) je hárok odvodený zo stĺpca J a prvý voľný riadok príslušného hárka
5 pri prepise podľa Tvojho kódu (ak by bolo ošetrené vracanie sa na zdrojový hárok) by pri každom spustení od posledného riadka cieľového hárka zapísal opäť všetky výskyty zdrojového hárka (vždy prejde celý cyklus od posledného riadka po tretí zdroja)

Takže:
vložením nového riadka do hárka Přehled hneď vykonaj kópiu tohto riadka do hárka určeného obsahom stĺpca "J" (nechápem tie MsgBoxy - to je len na testovanie? Pôvodne boli hárky len 4: M, Ž, JRI, JRY)
(To akože bude existovať hárok "Jarošov" a pod?)

No, když Ti to takhle stačí, proč ne...
Jsou tam ale věci, které bych takhle určitě nenechal (o něčem už jsem psal):
- větvení ElseIf bych úplně odstranil
- vyhnul bych se používání .Select
- pro kopírování bych použil tu druhou zjednodušenou verzi s parametrem "Destination"
- smazání listů bych provedl v cyklu "For Each" jediným příkazem "Range(...).ClearContents"
- k zadání dat bych použil místo InputBoxů vstupní formulář nebo umožnil přímo zadat do tabulky. V obou případech máš mnohem větší možnosti pohlídat si validnost vstupních dat

A malá poznámka nakonec: co rodná čísla a GDPR?

No jo, mazanie celého cieľa a jeho kompletné znovunaplnenie v určitých prípadoch má význam.
Postupné napĺňanie napr. spôsobí chybu (resp spätne nenapraví stav v ostatných hárkoch) pokiaľ nejaký riadok hárka "Přehled" spätne vymažeš...
Preto je vhodné len ak spätná oprava nie je prípustná, na čom je stavaný môj príklad.

Tvoj posledný kód som neštudoval, len som nahliadol, ale udrelo mi do očí Tvoje mazanie...

Ako prvá rada pri úprave kódu zazanamenaného záznamníkom sa odporúča mazať dvojice .Select a Selection

Takže príklad:

Sheets("Zoznam").Select
Range("A1:A1").Select
Selection.ClearContents

sa dá zjednodušiť na jediný riadok:

Sheets("Zoznam").Range("A1:A10").ClearContents

pričom nedôjde k žiadnym preblikávaniam po čiastkových cieľoch, príkaz sa vykoná bez akéhokoľvek označovania oblastí
(dá sa obísť aj príkazom Application.ScreenUpdating = False ale elegantnejšie je vynechať z kódu všetku nadbytočnosť než maskovať nedokonalosti)

S tím přidáním člena si pohraju dále, o tom funkčním formuláři jsem v podstatě nevěděl, takže naštuduju a určitě budu používat, díky moc za inspiraci. Jinak teda kódy jsem opravil. viz:

Sub Smazani()

Sheets("KKY").Range("B3:K1000").ClearContents
Sheets("ZCI").Range("B3:K1000").ClearContents
Sheets("MZKY").Range("B3:K1000").ClearContents
Sheets("JAR").Range("B3:K1000").ClearContents
Sheets("PŘÍPRAVKY").Range("B3:K1000").ClearContents
Sheets("JKY").Range("B3:K1000").ClearContents
Sheets("ZKY").Range("B3:K1000").ClearContents
Sheets("JUNI").Range("B3:K1000").ClearContents
Sheets("NEZAŘAZENO").Range("B3:K1000").ClearContents

End Sub

A ty slavné ELSEIF jsem teda převedl na CASE, vypadá to že to funguje, tak doufám že správně :

Sub Kopirovani()

Smazani

Sheets("Přehled").Select

Application.ScreenUpdating = False ' zrychluje makro

y = Range("B3").End(xlDown).Row ' PosledniZapsanyRadek, B3 znamená že se jedná o B sloupec

For i = y To 3 Step -1 ' uloží do i poslední zapsaný řádek , který nalezl jako y, a začně cyklus, začíná od třetího řádku dolů, 3 znamená že se jede od třetího řádku

Skupina = Cells(i, 10) ' skupina je název proměnné, pro mě to znamená buňku na jejiž základě se rozřazuje, a je to 10. sloupec

Select Case Skupina 'vyhodnoceni buňky
Case "KKY"
Range(Cells(i, 2), Cells(i, 11)).Copy
Sheets("KKY").Select
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).PasteSpecial xlPasteValues
Case "ZCI"
Range(Cells(i, 2), Cells(i, 11)).Copy
Sheets("ZCI").Select
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).PasteSpecial xlPasteValues
Case "MZKY"
Range(Cells(i, 2), Cells(i, 11)).Copy
Sheets("MZKY").Select
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).PasteSpecial xlPasteValues
Case "JAR"
Range(Cells(i, 2), Cells(i, 11)).Copy
Sheets("JAR").Select
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).PasteSpecial xlPasteValues
Case "PŘÍPRAVKY"
Range(Cells(i, 2), Cells(i, 11)).Copy
Sheets("PŘÍPRAVKY").Select
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).PasteSpecial xlPasteValues
Case "JKY"
Range(Cells(i, 2), Cells(i, 11)).Copy
Sheets("JKY").Select
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).PasteSpecial xlPasteValues
Case "ZKY"
Range(Cells(i, 2), Cells(i, 11)).Copy
Sheets("ZKY").Select
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).PasteSpecial xlPasteValues
Case "JUNI"
Range(Cells(i, 2), Cells(i, 11)).Copy
Sheets("JUNI").Select
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).PasteSpecial xlPasteValues
Case ""
Range(Cells(i, 2), Cells(i, 11)).Copy
Sheets("NEZAŘAZENO").Select
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).PasteSpecial xlPasteValues
Case Else

End Select

Sheets("Přehled").Select

Next i

Application.ScreenUpdating = True ' zrychluje makro

End Sub

Dodatečně vám oboum děkuji za Váš čas :-)

Nejprve bych na začátku zavedl zkratku na hlavní list "Přehled", abych na něj mohl snáze odkazovat:

Set wsPrehled = ThisWorkbook.Worksheets("Přehled")

Pak bych zjednodušil mazání všech listů (s výjimkou právě Přehledu) do cyklu přes všechny listy:

For Each ws In ActiveWorkbook.Worksheets
  If ws.Name <> wsPrehled.Name then
    ws.Range("B3:K1000").ClearContents
  End If
Next ws

Už dříve jsem psal, že ty Case ani nepotřebuješ a celé kopírování můžeš značně zjednodušit. Musíš si ale vytvořit funkci testující existenci sešitu (TestSheetExist). Navíc se vyhýbej používání Select, raději používej Activate:


Function TestSheetExist(TestSheetName As String) As Boolean
  On Error Resume Next ' error handler-zamezí vzniku chyby
  Set wsSheet = Worksheets(TestSheetName)
  TestSheetExist = True  ' předpokládám existenci listu
  If Err.Number <> 0 Then ' chyba vznikla --> list neexistuje
    TestSheetExist = False
  End If
  On Error GoTo 0  ' zapne standardní zachytávání chyb
End Function

Skupina = Cells(i, 10)
If not TestSheetExist(Skupina) Then  ' List neexistuje - kopíruji na "NEZAŘAZENO"
  Skupina = "NEZAŘAZENO"
End If
wsPrehled.Range(Cells(i, 2), Cells(i, 11)).Copy 
Sheets(Skupina).Activate
x = Range("B1").End(xlDown).Row + 1
Cells(x, 2).Activate
ActiveSheet.Paste
wsPrehled.Activate

Něco o zlozvyku používat Select místo Activate.

Napadá mě i další vylepšení - vést si pole s čísly volných řádků pro všechny listy - vyhneš se tak zjišťování prvního volného řádku v každém kroku cyklu.

Ďalšia čiastková pripomienka k modulu 1:
Nemusíš najprv načítavať InputBoxy do premenných a v ďalšom bloku priraďovať premenné do buniek, môžeš to robiť naraz:

Range("B" & PrvniPrazdyRadek) = InputBox("Zadej Jméno:")

avšak to by ti musel PrvniPrazdnyRadek fungovať (nefunguje, pretože pod štartovacou bunkou musí byť minimálne ešte jedna vyplnená, inak skáče na absolútne dno excelu)

Okrem toho inputbox ti takto prijme čokoľvek. Pri sabotérovi to neprejde ;-)

Fucktická poznámka k poznámke cyklu v module 2: nezačína od 3. riadku nadol ale od posledného riadku späť po 3. riadok a teda zoznamy v hárkoch budú v opačnom portadí než sa vyskytujú v hárku Přehled...

Za ďalšie: kašli na vlepovanie hodnôt, keďže cieľové hárky máš rovnako formátované (t.j. môžeš to vlepiť cakom-prask tak ako to je v Přehled-u.
Týmpádom môžeš použiť krásny tvar pre kopírovanie: Zdroj.Copy(Cieľ)
A ako som Ti to ukázal v mojom príklade (a ako Ti to opakuje Machr) nie je treba prechádzať názvy hárkov ani v bloku If ani v Select Case, jednoducho cieľový hárok máš daný v bunke v stĺpci J

Takže celý ale celičičký tvoj kód

Sheets("Přehled").Select

Application.ScreenUpdating = False ' zrychluje makro

y = Range("B3").End(xlDown).Row ' PosledniZapsanyRadek

For i = y To 3 Step -1 ' uloží do i poslední zapsaný řádek , který nalezl jako y, a začně cyklus, začíná od třetího řádku dolů

    If Cells(i, 10) = "KKY" Then '10 je označení sloupce J -> rozeznává v jaké se hráč nachází skupině
         Range(Cells(i, 2), Cells(i, 11)).Copy
         Sheets("KKY").Select
         x = Range("B1").End(xlDown).Row + 1
         Cells(x, 2).PasteSpecial xlPasteValues
         Sheets("Přehled").Select
    ElseIf Cells(i, 10) = "ZCI" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("ZCI").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).PasteSpecial xlPasteValues
        Sheets("Přehled").Select
    ElseIf Cells(i, 10) = "MZKY" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("MZKY").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).PasteSpecial xlPasteValues
        Sheets("Přehled").Select
    ElseIf Cells(i, 10) = "VKV" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("VKV").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).PasteSpecial xlPasteValues
        Sheets("Přehled").Select
    ElseIf Cells(i, 10) = "PŘÍPRAVKY" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("PŘÍPRAVKY").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).PasteSpecial xlPasteValues
        Sheets("Přehled").Select
    ElseIf Cells(i, 10) = "JKY" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("JKY").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).PasteSpecial xlPasteValues
        Sheets("Přehled").Select
    ElseIf Cells(i, 10) = "ZKY" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("ZKY").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).PasteSpecial xlPasteValues
        Sheets("Přehled").Select
    ElseIf Cells(i, 10) = "JUNI" Then
        Range(Cells(i, 2), Cells(i, 11)).Copy
        Sheets("JUNI").Select
         x = Range("B1").End(xlDown).Row + 1
        Cells(x, 2).PasteSpecial xlPasteValues
        Sheets("Přehled").Select
    Else: Cells(i, 10) = ""
    Sheets("Přehled").Select
    End If
    
Next i

Application.ScreenUpdating = True ' zrychluje makro


vyriešiš týmto:

For i = 3 To Sheets("Přehled").Range("B3").End(xlDown).Row
    Sheets("Přehled").Range("B" & i & ":K" & i).Copy (Sheets(Sheets("Přehled").Range("J" & i).Value).Range("B" & Sheets(Sheets("Přehled").Range("J" & i).Value).Range("B1").End(xlDown).Row + 1))
Next i

pred to si ešte daj to Smazání upravené podľa Machra a máš to

Tak tu to máš vrátane vstupného formulára a pár úkonov naviac...
K dokonalosti to má sakra ďaleko ale dá sa s tým :-D
(napr kontroly, či vstupné údaje nie sú nezmysly - viď príklady :-D)

Skúšaj, testuj, nevylučujem, že niekde nájdeš ešte nejaký kiks nebo kix? ;-)

P.S.
- pri zadávaní stačí entrovať - políčka nasledujú v poradí, takže nie je potrebné klikať do nich, akurát pri rozbaľovacom zozname, optButtonoch a tlačítku už musíš prejsť na myš...
- máš doplnené ukotvené priečky v hárkoch aby sa Ti neodrolovali záhlavia
- máš rozšírené mazanie polí až po riadok 2002, keďže až tam máš spodok tabuľky (dalo by sa riešiť, aby tabuľky nemali riadky, kým si ich nepridajú podľa potreby, vrátane poradových čísel)
- tlačítko "Aktualizace listů" je tam pre prípad, že spätne upravíš údaje v Přehledu (manuálne), napr vynecháš nejaké osoby zo zoznamu a chceš, aby sa všetky listy zaktualizovali podľa tohto stavu
atď atď ;-)

Uč sa a tvor ďalej ;-)

Zpět do poradny Odpovědět na původní otázku Nahoru