Neregistrovaný Přihlásit Registrovat

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í

tom-pokus.xlsm 19.26 KiB
Jsou zobrazeny jen nové odpovědi. Zobrazit všechny
Předmět Autor Datum
díky všem za poznatky, ve volném čase udělám efektivnější kód :) btw. já jen zpracoval dokument, s…
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é…
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…
Thomasino 11.09.2019 13:10
 Thomasino
Ďalšia čiastková pripomienka k modulu 1: Nemusíš najprv načítavať InputBoxy do premenných a v ďalšom…
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…
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

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 :-)

Ď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 ;-)

databaze-v3.xlsm 0.96 MiB

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