< návrat zpět
MS Excel
Téma: Dim - číslo nebo velké písmeno 
Zaslal/a Alfan 30.5.2023 10:41
Dobrý den,
mohli byste mi někdo , prosím, zeditovat níže uvedené makro?
V Dimenzi "kj" může být číslo nebo velké písmeno.
Měl jsem makro o vás tady z fóra na jméno a příjmení, ale tam jsem kontroloval jen to, že tam jsou jen písmena a první písmeno je velké.
Tady potřebuji:
buď číslo nebo velké písmeno a zároveň délka 7 znaků (alfanumerických).
Zkusil jsem to sám, ale zkolaboval jsem na číslech.
Přkládám i soubor.
Děkuji.
Radek
Sub Nova_KJ()
Dim kj As String
Dim jmeno As String
Dim radek As Long
On Error Resume Next 'pokud uživatel stiskne klávesu ESC, kód skočí do řádku s "Exit Sub"
Do
kj = InputBox("Zadejte novou RZ: (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")
If Err.Number <> 0 Then 'pokud uživatel stiskne klávesu ESC, ukončí se makro
Exit Sub
End If
'jmeno = InputBox("Zadejte jméno: (bez mezer, čísel a speciálních znaků) - ukončit můžete klávesou ESC nebo kliknutím na křížek nebo na klávesu Cancel")
If Err.Number <> 0 Then 'pokud uživatel stiskne klávesu ESC, ukončí se makro
Exit Sub
End If
On Error GoTo 0 'vynulování chybového čísla
If kj = "" Then
Exit Sub
End If
If Not (IsUpper(kj) And _
IsNumeric(kj) And _
Len(kj) = 7 Or Len(kj) = 0 Or Len(kj) < 7) Then
'If Not (IsUpper(Left(prijmeni, 1)) And IsUpper(Left(jmeno, 1)) And _
' IsOnlyLowerCase(Right(prijmeni, Len(prijmeni) - 1)) And _
'IsOnlyLowerCase(Right(jmeno, Len(jmeno) - 1)) And _
'IsOnlyLetters(prijmeni) And IsOnlyLetters(jmeno) And _
'Len(prijmeni) > 1 And Len(jmeno) > 1) Then
MsgBox "Opravte RZ - (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"
Else
If Sheets("kj").Range("A2") = "" Then
radek = 2
Else
radek = Sheets("kj").Range("A" & Rows.Count).End(xlUp).Row + 1
End If
Sheets("kj").Range("A" & radek).Value = kj
Exit Do
End If
Loop
With ThisWorkbook.Sheets("kj")
.Range("A2").Sort key1:=.Range("A2"), order1:=xlAscending, Header:=xlYes
End With
Dim ws As Worksheet
Dim lastRow As Long, i As Long, j As Long
Set ws = ThisWorkbook.Sheets("kj") 'název listu
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow 'prochází každý řádek od 2. řádku až po poslední
For j = i + 1 To lastRow 'prochází každý řádek nad aktuálním řádkem
If ws.Cells(i, "A").Value = ws.Cells(j, "A").Value Then 'pokud jsou hodnoty v sloupci A stejné, vymaže řádek
ws.Rows(j).EntireRow.Delete
lastRow = lastRow - 1 'aktualizuje poslední řádek, protože byl odebrán řádek
j = j - 1 'decrementuje j, aby se při dalším průchodu prozkoumal nový řádek, na který se posunul
End If
Next j
Next i
MsgBox ("HOTOVO- nová RZ uložena")
End Sub
Function IsUpper(text As String) As Boolean
IsUpper = (text = UCase(text))
End Function
Function IsOnlyLowerCase(text As String) As Boolean
IsOnlyLowerCase = (text = LCase(text))
End Function
Function IsOnlyLetters(text As String) As Boolean
Dim i As Integer
For i = 1 To Len(text)
If Not (Asc(Mid(text, i, 1)) >= 65 And Asc(Mid(text, i, 1)) <= 90) And _
Not (Asc(Mid(text, i, 1)) >= 97 And Asc(Mid(text, i, 1)) <= 122) And _
Not (Asc(Mid(text, i, 1)) >= 138 And Asc(Mid(text, i, 1)) <= 254) Then
IsOnlyLetters = False
Exit Function
End If
Next i
IsOnlyLetters = True
End Function
Příloha: 
54963_wall.zip (46kB, staženo 6x)
Milan-158(30.5.2023 15:41)#054965 
tato podmínka je špatně:
If Not (IsUpper(kj) And _
IsNumeric(kj) And _
Len(kj) = 7 Or Len(kj) = 0 Or Len(kj) < 7) Then
za prvé kontrolovat velká malá písmena je zbytečná buzerace uživatele, u SPZ to kódem změňte na UCASE, u jména první velké a ostatní LCASE. Ale problém je IsNumeric(kj), což v případě SPZ nebude nikdy splněno
citovatMilan-158(30.5.2023 16:23)#054966 Nahraďte část svého kódu (po loop) tímto:
Sub Nova_KJ()
Dim kj As String
Dim jmeno As String, strX As String
Dim radek As Long, x As Integer, m As Integer
Dim aPovoleneZnaky As Variant
Dim boNalezeno As Boolean
aPovoleneZnaky = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0")
On Error Resume Next 'pokud uživatel stiskne klávesu ESC, kód skočí do řádku s "Exit Sub"
kj = InputBox("Zadejte novou RZ: (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")
If Err.Number <> 0 Then 'pokud uživatel stiskne klávesu ESC, ukončí se makro
Exit Sub
End If
If kj = "" Then
Exit Sub
End If
'převeď to na velké a odstřel případné mezery
kj = Trim(UCase(kj))
'kontrola na počet znaků
If Len(kj) < 7 Then
MsgBox kj & vbCrLf & "to je příliš málo znakú pro RZ"
Exit Sub
End If
If Len(kj) > 7 Then
If vbNo = MsgBox(kj & vbCrLf & "Příliš mnoho znakú pro RZ!" & vbCrLf & "opravdu pokračovat?", vbYesNo) Then Exit Sub
End If
'kontrola na povolené znaky (abecedu a číslice)
For x = 1 To Len(kj)
'znak po znaku se bude zkoumat jestli je ze seznamu (pole) povolených znaků
strX = Mid(kj, x, 1)
boNalezeno = False
For m = LBound(aPovoleneZnaky) To UBound(aPovoleneZnaky)
If aPovoleneZnaky(m) = strX Then
boNalezeno = True
Exit For
End If
Next m
If boNalezeno = False Then
MsgBox strX & " není povolený znak pro SPZ!"
Exit Sub
End If
Next x
If Sheets("kj").Range("A2") = "" Then
radek = 2
Else
radek = Sheets("kj").Range("A" & Rows.Count).End(xlUp).Row + 1
End If
Sheets("kj").Range("A" & radek).Value = kjcitovatStalker(30.5.2023 20:53)#054967 
Pokud by nebylo potřeba v msgboxu zobrazit "závadný znak", dal by se využít regulární výraz.
Příloha: 54967_wall.zip (52kB, staženo 2x) citovatMilan-158(31.5.2023 8:35)#054969 Pole s povolenými znaky je v tomto případě zbytečná technika, použil jsem to z existující funkce co používám pro nahrazování diakritiky. Pro účely RZ to plně postačí takto:
strPovoleneZnaky = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
'kontrola na povolené znaky (abecedu a číslice)
For x = 1 To Len(kj)
'znak po znaku se bude zkoumat jestli je ze seznamu (pole) povolených znaků
strX = Mid(kj, x, 1)
If InStr(1, strPovoleneZnaky, strX) = 0 Then
MsgBox strX & " není povolený znak pro SPZ!"
Exit Sub
End If
Next xcitovat
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.
Příloha: 54970_wall.zip (47kB, staženo 2x) citovatAlfan(31.5.2023 10:07)#054971 @elninoslov
Zkusil jsem váš kod, ale vyskakuje mi tam tato chyba:
Set LO = wsKJ.ListObjects("DataKj") 'název Tabulky na listě kj
List má název "kj" a je na něm tabulka s názvem "DataKj"
Ostatním samozřejmě také děkuji.
Radek
citovat elninoslov(31.5.2023 10:37)#054973 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.
citovatAlfan(31.5.2023 10:57)#054975 Jj, už jsem použil váš soubor s tím přejmenováním.
Když zadám například 1234567, tak se RZ uloží.
Ale v RZ musí být minimálně jedno písmeno a to na druhé pozici.
U elektroauta jsou první dva znaky "EL".
Celkový počet znaků RZ je 7, ty na přání mají 8.
Šlo by to nějak zakomponovat do těch podmínek?
Děkuji.
Radek
citovatelninoslov(31.5.2023 11:28)#054976 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} ...)
Příloha: 54976_wall.zip (46kB, staženo 2x) citovatAlfan(1.6.2023 12:35)#054979 Jj, jsou tam i kratší, já tam dal vše, pak to budu mít vyčištěné před prvním nasazením.
Ale stále, když zadám například 7 pouze písmen, tak se to uloží.
Já to nenapsal původně. Mělo by tam být číslo, někde, u ele aut bude třeba až od třetí pozice, ale bude tam vždy alespoň jedno číslo.. A písmeno musí být na druhé pozici.
Díky.
Radek
kam vám mohu přispět?citovat
RSS nejnovější články