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

54963_wall.zip (46kB, staženo 6x)

Zaslat odpověď >

Strana: « předchozí 1 2

elninoslov(1.6.2023 13:52)#054981

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

Příloha: zip