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

Příspěvky uživatele

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

1. V tom G sa to "splnené" objaví vzorcom, alebo je zadané manuálne napísaním či výberom z výberového zoznamu?
2. Môže nastať zmena viacerých buniek v G naraz?
3. Čo ak v F už dátum je?

Target.Column nemôžete testovať, ak meníte viac buniek a G je iba súčasťou. Treba to inak. Odpovedzte na upresňujúce otázky.

Urobte si dočasné odstavenie Events, napr.:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim testValue As Variant
Dim myRange As Range
Dim myChangedRNG As Range


Set myRange = Range("D8:D372")

Set myChangedRNG = Intersect(Target, myRange)
If myChangedRNG Is Nothing Then Exit Sub 'ignoruje změny mimo určený rozsah
If myChangedRNG.Cells.Count > 1 Then Exit Sub 'ignoruje změny s více než jednou buňkou

testValue = myChangedRNG.Value

If IsNumeric(testValue) Then

Application.EnableEvents = False
On Error GoTo KONIECTESTU

If testValue >= 0 And testValue < 1 Then
myChangedRNG.Value = Format(testValue, "h:mm")
ElseIf testValue >= 1 And testValue < 24 Then
If Int(testValue) = testValue Then
myChangedRNG.Value = Format(testValue, "0") & ":00"
Else
myChangedRNG.Value = Format(testValue, "h:mm")
End If
End If

KONIECTESTU:
On Error GoTo 0
Application.EnableEvents = True
End If

End Sub

Prvý nástrel, nemám viac času ...

Skúste makro

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse