• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

Příspěvky uživatele

Ak ste priložil nejaký súbor, tak neprešiel. Buď je to xlsm a treba ho za-ZIP-ovať, alebo je veľký a treba ho zmenšiť tak cca do 300 kB.

O akú verziu Office sa jedná?

Ktorú verziu riešenia máte na mysli? Ak tú od "lubo", potrebujete Office 2021 alebo 365.

Odkaz na iný list (apostrofy nie sú potrebné ak názov neobsahuje medzeru)
'názov listu'!A1:B1

V prípade prevedenia oblasti na Tabuľku (nazývané ako Tabuľka s veľkým "T", alebo ListObject alebo Excel Table) cez Ctrl+T, sa na žiadny list neodkazujete. Ale iba na názov Tabuľky prípadne na jej stĺpce
tblUdaje
tblUdaje[[cislo1]:[cislo2]]
...

Iná možnosť by bol maticový vzorec, kde netreba testovať najskôr "04", no zápis by musel byť korektný (počet znakov "?" Vám nesedí, máte v 3 číselnej maske 4 otázniky, čo je 7 znakov). Tak radšej takto:
04*
511*
518*

=IFERROR(INDEX(dopln!$B$2:$B$4;MATCH("*";IFERROR(""&MATCH(dopln!$A$2:$A$4;List2!A2;0);FALSE);0));"")
=IFERROR(INDEX(dopln!$B$2:$B$4;POZVYHLEDAT("*";IFERROR(""&POZVYHLEDAT(dopln!$A$2:$A$4;List2!A2;0);NEPRAVDA);0));"")

Dajú sa použiť rôzne kombinácie COUNTIF, INDEX, SMALL, MATCH, VLOOKUP...

@lubo: už som na tú 2021 zlomený, len musím ešte počkať

??? Celý ten kód je divný. Od prepočtu tých listov na kotúče, zvyšku a pod., až po 2x po sebe určovanie menného zoznamu listov a pod. Včetne toho, že Váš príklad urobí listy
1. list "1" - "2/4" - "1000"
2. list "2" - "3/4" - "1000"
3. list "3" - "4/4" - "600"
4. list "4" - "1/4" - "1000"
PDF to vytvorí s 8 stránkami (každý list na 2 str). Ak pochopím, čo to tam ako rátate (pre mňa neskutočne nepochopiteľný zápis v kóde), tak bude stačiť pri vytváraní iba zmeniť poradie listov.

EDIT:
To nebude celý kód, všakže? Vzhľadom na nepoužité globálne premenné ako napr. "varinput".

Toto myslíte ako fakt vážne?
...Filename:=xlQualityStandard...
to je kvalita PDF a nie názov súboru

List1 - musíte nakopírovať vzorce na dostatočne veľkú oblasť
List2 - obabrete to automatickým rozširovaním cez objekt Tabuľka

Ak teda už fakt neviete čo s tou likviditou, a prehadzujete tie prebytky hospodárenia doma vidlami, tak pošlite za kalíšok pre fórum
Pekný deň.

Pridať kontrolu čísla je prkotina. Najdlhšie na celom kóde je skladanie Msg oznamu :)
Sub Nova_KJ()

Dim kj As String, NoZnak As String, No2Znak As String, Z As String * 1, MSG As String
Dim i As Long, bNumOK As Boolean
Dim LO As ListObject

Const VALID As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" 'validní znaky celkově
Const VALID2ZNAK As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 'validní znaky 2. znaku

Set LO = wsKJ.ListObjects("DataKj") 'název Tabulky na listě kj

Do
On Error Resume Next 'pokud uživatel stiskne klávesu ESC nebo Cancel nebo křížek nebo zadá "", kód skočí do řádku s "Exit Sub"
kj = UCase(InputBox("Zadejte novou RZ:" & vbNewLine & "(7 znaků, bez mezer a speciálních znaků) - ukončit můžete klávesou ESC nebo kliknutím na křížek nebo na klávesu Cancel", Default:=kj))

If Err.Number <> 0 Or kj = "" Then Exit Sub 'pokud uživatel stiskne klávesu ESC nebo Cancel nebo křížek nebo zadá "", ukončí se makro
On Error GoTo 0 'vynulování chybového čísla

If Len(kj) < 7 Or Len(kj) > 8 Then
MsgBox "Opravte RZ - (nesprávný počet znaků {" & Len(kj) & "}, vyžadováno 7-8 znaků)", vbExclamation
Else
NoZnak = "" 'nepovolené znaky
No2Znak = "" 'nesplněna podmínka 2. znak = písmeno
bNumOK = False 'příznak, zda text obsahuje číslo

For i = 1 To Len(kj) 'prověření znaků
Z = Mid$(kj, i, 1)
bNumOK = bNumOK Or IsNumeric(Z) 'někde je číslo
If i = 2 Then 'ověření, zda je 2. znak písmeno
If InStr(1, VALID2ZNAK, Z) = 0 Then No2Znak = vbNewLine & "Znak č. 2 {" & IIf(Z = " ", "mezera", Z) & "} musí být písmeno A-Z"
End If
If InStr(1, VALID, Z) = 0 Then NoZnak = NoZnak & vbNewLine & vbTab & IIf(Z = " ", "mezera", Z)
Next i

MSG = NoZnak & No2Znak 'složení správy o chybě
MSG = IIf(MSG = "", "", vbNewLine & vbNewLine & "Nepovolené znaky :" & MSG)
If Not bNumOK Then MSG = MSG & vbNewLine & vbNewLine & "Chybí aspoň 1 číslo"

If MSG <> "" Then
MsgBox "Opravte RZ - (bez mezer a speciálních znaků)" & MSG, vbExclamation
Else
Exit Do 'opakování končí validním zadáním
End If
End If
Loop

wsKJ.Cells(LO.Range.Columns(1).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1, "A").Value2 = kj 'přidání kj na konec Tabulky DataKj
LO.Range.RemoveDuplicates Columns:=1, Header:=xlYes 'smazání duplicitních kj
LO.Range.Columns(1).Sort key1:=LO.Range.Columns(1), order1:=xlAscending, Header:=xlYes 'seřazení kj

MsgBox "HOTOVO - nová RZ uložena", vbInformation
End Sub

Ak som to pochopil tak napr.
Sub Nova_KJ()

Dim kj As String, NoZnak As String, No2Znak As String, Z As String * 1
Dim i As Long
Dim LO As ListObject

Const VALID As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" 'validní znaky celkově
Const VALID2ZNAK As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 'validní znaky 2. znaku

Set LO = wsKJ.ListObjects("DataKj") 'název Tabulky na listě kj

Do
On Error Resume Next 'pokud uživatel stiskne klávesu ESC nebo Cancel nebo křížek nebo zadá "", kód skočí do řádku s "Exit Sub"
kj = UCase(InputBox("Zadejte novou RZ:" & vbNewLine & "(7 znaků, bez mezer a speciálních znaků) - ukončit můžete klávesou ESC nebo kliknutím na křížek nebo na klávesu Cancel", Default:=kj))

If Err.Number <> 0 Or kj = "" Then Exit Sub 'pokud uživatel stiskne klávesu ESC nebo Cancel nebo křížek nebo zadá "", ukončí se makro
On Error GoTo 0 'vynulování chybového čísla

If Len(kj) < 7 Or Len(kj) > 8 Then
MsgBox "Opravte RZ - (nesprávný počet znaků {" & Len(kj) & "}, vyžadováno 7-8 znaků)", vbExclamation
Else
NoZnak = "" 'nepovolené znaky
No2Znak = "" 'nesplněna podmínka 2. znak = písmeno
For i = 1 To Len(kj) 'prověření znaků
Z = Mid$(kj, i, 1)
If i = 2 Then 'ověření, zda je 2. znak písmeno
If InStr(1, VALID2ZNAK, Z) = 0 Then No2Znak = vbNewLine & "Znak č. 2 {" & IIf(Z = " ", "mezera", Z) & "} musí být písmeno A-Z"
End If
If InStr(1, VALID, Z) = 0 Then NoZnak = NoZnak & vbNewLine & IIf(Z = " ", "mezera", Z)
Next i

If NoZnak & No2Znak <> "" Then
MsgBox "Opravte RZ - (bez mezer a speciálních znaků)" & vbNewLine & "Nepovolené znaky :" & NoZnak & No2Znak, vbExclamation
Else
Exit Do 'opakování končí validním zadáním
End If
End If
Loop

wsKJ.Cells(LO.Range.Columns(1).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1, "A").Value2 = kj 'přidání kj na konec Tabulky DataKj
LO.Range.RemoveDuplicates Columns:=1, Header:=xlYes 'smazání duplicitních kj
LO.Range.Columns(1).Sort key1:=LO.Range.Columns(1), order1:=xlAscending, Header:=xlYes 'seřazení kj

MsgBox "HOTOVO - nová RZ uložena", vbInformation
End Sub
Ale máte tam aj iné dĺžky kj (3, 9, 6, aj s nepovolenými znakmi {medzera, pomlčka} ...)

Ja som objekt toho Vášho listu "kj" vo VBA premenoval z List5 na wsKJ. To je tzv CodeName listu (nezávislé od popisu na ušku listu). V prílohe to je vidieť. Je to namiesto
Set ws = ThisWorkbook.Sheets("kj")
alebo namiesto nič nehovoriaceho List5.

Do deklarácií pridajte
Dim S() As String, i As Integer
A potom toto
Stlp = wsOdstranovanie.Range("B1").Value
Stlp = Stlp & ":" & Stlp
nahraďte týmto
S = Split(wsOdstranovanie.Range("B1").Value, ",")
For i = 0 To UBound(S)
S(i) = S(i) & IIf(InStr(1, S(i), ":") > 0, "", ":" & S(i))
Next i
Stlp = Join(S, ",")
a ešte pred
Set appExcel = New Excel.Application
pridajte
Stlp = Replace(rng.Address(0, 0), ",", ";")
Zaujímavé je, že v obslužnom Exceli sa oblasti stĺpcov v Range odkazujú pomocou čiarky A:A,C:C,FM:FN no v skrytej druhej inštancii Excelu sa odkazujú pomocou bodkočiarky A:A;C:C;FM:FN. Inak to vedie k chybe. Každopádne Vy po úprave zadávate nasledovný formát do bunky B1
Napr.:
A
A,C
A,C,FN
A,C,FM:FN
A:A,C:C,FM:FN
A:B,G,FM:FO
...
a obdobné kombá

Presne tak. Kým som sa dostal k dokončeniu, už ste to postol. Vložím to sem teda ešte kvôli iným veciam, ako použitie Tabuľky keď už ju tam máte, odstránenie duplicít bez cyklu.
Sub Nova_KJ()

Dim kj As String, NoZnak As String
Dim i As Long
Dim LO As ListObject

Const VALID As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" 'validní znaky

Set LO = wsKJ.ListObjects("DataKj") 'název Tabulky na listě kj

Do
On Error Resume Next 'pokud uživatel stiskne klávesu ESC nebo Cancel nebo křížek nebo zadá "", kód skočí do řádku s "Exit Sub"
kj = UCase(InputBox("Zadejte novou RZ:" & vbNewLine & "(7 znaků, bez mezer a speciálních znaků) - ukončit můžete klávesou ESC nebo kliknutím na křížek nebo na klávesu Cancel", Default:=kj))

If Err.Number <> 0 Or kj = "" Then Exit Sub 'pokud uživatel stiskne klávesu ESC nebo Cancel nebo křížek nebo zadá "", ukončí se makro
On Error GoTo 0 'vynulování chybového čísla

If Len(kj) <> 7 Then
MsgBox "Opravte RZ - (nesprávný počet znaků {" & Len(kj) & "}, vyžadováno 7 znaků)", vbExclamation
Else
NoZnak = "" 'nepovolené znaky
For i = 1 To 7 'prověření znaků
If InStr(1, VALID, Mid$(kj, i, 1)) = 0 Then NoZnak = NoZnak & vbNewLine & IIf(Mid$(kj, i, 1) = " ", "mezera", Mid$(kj, i, 1))
Next i

If NoZnak <> "" Then
MsgBox "Opravte RZ - (bez mezer a speciálních znaků)" & vbNewLine & "Nepovolené znaky :" & NoZnak, vbExclamation
Else
Exit Do 'opakování končí validním zadáním
End If
End If
Loop

wsKJ.Cells(LO.Range.Columns(1).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1, "A").Value2 = kj 'přidání kj na konec Tabulky DataKj
LO.Range.RemoveDuplicates Columns:=1, Header:=xlYes 'smazání duplicitních kj
LO.Range.Columns(1).Sort key1:=LO.Range.Columns(1), order1:=xlAscending, Header:=xlYes 'seřazení kj

MsgBox "HOTOVO - nová RZ uložena", vbInformation
End Sub
Tie ostatné makrá sú divné tiež. Tie som zatiaľ neriešil.

Vo virtuálke mám starý MacOS Siera + Office 2016.

Konkrétne táto chyba vzniká pri pokuse vytvoriť objekt
CreateObject("Scripting.FileSystemObject")
ktorý je použitý na vytvorenie chýbajúcej adresárovej štruktúry. MacOS nič také nepozná. Tam by sa to muselo riešiť jedine cez MkDir v cykle alebo rekurzii.

Oddeľovač ciest je "/" namiesto "\".

Ďalším problémom je nutnosť používať na overenie existencie cesty Dir() obalenie do On Error Resume Next. To je prkotina, ale gro problému pri nej spočíva inde. MacOS nedovolí prístup do adresárov len tak. Musíte povoliť prístup. To nejde urobiť programovo. Sú iba nejaké adresáre, ktoré toto nevyžadujú, ale cesta k nim je krkolomná, názvy nezmyselné, a navyše vo Finder (Prieskumník) sa k nim nedostanete. Treba použiť zase ďalší skript, ktorý Vám vytvorí na tento adresár odkazy do Obľúbených a neviem kam ešte.
Popisuje to aj RdB:
Make and Mail PDF files with VBA code on your Mac
Problems with Apple’s sandbox requirements

Uznajte, že používať namiesto plochy toto
/Users/rondebruin/Library/Group Containers/UBF8T346G9.Office
je na palicu. Cez prieskumníka sa tam navyše normálne nedostanete.

Editácia makra v MacOffice je učinená hrôza. Chýba náhľad na hodnotu premennej, okno Watches, Immediate, nefunguje Ctrl+C/V, nefunguje krok späť Ctrl+Z ...

Teda na celkové prerobenie makra na multifunkčnosť, vzhľadom na komplikácie, by som musel mať setsakramentsky dobrú náladu. A to teda nemám. Pôvodný kód bol môj, problém identifikovaný, riešiť sa mi to ale momentálne nechce.

Návrh cez polia a kolekcie.

1. Jedná sa o rozdelenie iba hodnôt, alebo tam sú aj vzorce, podmienené formáty, farby a pod?
2. Čo ak list s farbou existuje? Prepísať? Doplniť?
3. Čo ak existujú listy s farbami, aké nie sú v tabuľke? Ponechať? Odstrániť?

A ďalej sa ani nezamýšľam...

=VLOOKUP(S6;INDIRECT("'"&A7&"'!A26:I29");2;FALSE)
=SVYHLEDAT(S6;NEPŘÍMÝ.ODKAZ("'"&A7&"'!A26:I29");2;NEPRAVDA)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bunka As Range

Set Bunka = Intersect(Columns("G"), Target)

If Not Bunka Is Nothing Then
If Bunka.Value = "splnené" Then
With Bunka.Cells(1).Offset(0, -1)
If IsEmpty(.Value) Then
Application.EnableEvents = False
.Value = Date
Application.EnableEvents = True
End If
End With
End If
End If
End Sub

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse