Excel VBA - vytvoření databáze

díky všem za poznatky, ve volném čase udělám efektivnější kód :)

btw. já jen zpracoval dokument, s ničími daty já pracovat nebudu

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

pokiaľ tam však budeš mať skupinu, ktorá nemá svoj hárok alebo bude v hárku Přehled preklep v skupine, nastane chyba, preto je dobré doplniť i ošetrenie takejto chyby (tiež Ti to už napísal Machr)

Upravil som Ti Modul 2 - vložil som Ti tam makro "Prenos" a dve tlačítka
Skús si to spustiť - všetko sa prenesie.
Ešte si doplň zrušenie výberu oblastí po mazaní

vysvetlenie prenosového výrazu v prílohe

Tak tady máš ďalší stupienok vrátane kontroly existencie listu, vrátane minimalizácie kódu a s automatickým prenosom po ukončení zadania riadku vrátane mazania...
Ešte pre vstup urobiť namiesto inputboxov formulár a máš to (už sa na tom pracuje )

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
(napr kontroly, či vstupné údaje nie sú nezmysly - viď príklady )

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