Makro ima težavo pri prepoznavi črk č in ć

[Vikmar]

Pozdravljeni. Preko spajanja dokumentov s Excelovo datoteko imam izdelano Wordovo datoteko. V datoteki je večje število listov s tabelami. Posamezni listi so poimenovani različno. Ideja je, da se vsak posamezni list prekopira v datoteko, ki se poimenjuje po Priimku in imenu uporabnika iz tabele.Tako poimenovana datoteka se potem shrani v mapo z enakim priimkom in imenom. Preko Chatgpt imam izdelan makro, ki lepo deluje, se mu pa zatakne pri shranjevanju listov, ki vsebujejo črki č in ć. Mapo ustvari brez č-jev in ć-jev. Ko naleti na tak zapis moram dokument ročno shraniti. Verjetno to zato, ker je mapa v katero bi moral shraniti poimenovana namesto s črko č ali ć samo s črko c. Zanimivo se mi zdi, da s črkama Ž in Š nima težav.
Zanima me če se ta težava lahko reši. Chatgpt se vrti v krogu in mi ne zna zadeve rešiti ali pa jaz ne razumem, kaj mi hoče povedati. Če ne zahtevam preveč sprašujem ali lahko prilepim makro, da bi pogledali, če obstaja rešitev? Če imate preveč dela in to ni možno bom razumel! Hvala!

[admin]

Pozdravljeni,

Da, brez da bi videl makro, vam ne morem nič pomagati. Prilepite problematično kodo in bomo videli

[Vikmar]

Sem iskal, žal ne našel 'peti gumb zgoraj ' zato vam zopet v neprimerni obliki pošiljam celotno kodo v pregled.
'Sub SaveDocumentsToFolders()
Dim doc As Document
Dim rng As Range
Dim userName As String
Dim lastName As String
Dim firstName As String
Dim baseFolderPath As String
Dim folderPath As String
Dim filePath As String
Dim i As Long
Dim tbl As Table
Dim newDoc As Document
Dim r As Long, c As Long
Dim nameParts As Variant
Dim j As Long

' Nastavi dokument
Set doc = ActiveDocument

' Nastavi osnovno pot do mape
baseFolderPath = "D:\01_IZDELAVA VODENJA EVIDENCE\01_IZDELAVA APLIKACIJE ZA VODENJE EVIDENCE\03_VERZIJA 2024\01_DELOVNE DATOTEKE\MAPA Z LISTI UPORABNIKOV\"

' Preveri, ali osnovna mapa obstaja, in jo ustvari, ce ne obstaja
If Dir(baseFolderPath, vbDirectory) = "" Then
MkDir baseFolderPath
Debug.Print "Osnovna mapa ustvarjena: " & baseFolderPath
End If

' Preštej število razdelkov
For i = 1 To doc.Sections.Count
' Nastavi obseg na trenutni razdelek
Set rng = doc.Sections(i).Range

' Preveri, ali tabela obstaja
On Error Resume Next
Debug.Print "Število tabel v razdelku " & i & ": " & rng.Tables.Count
If rng.Tables.Count > 1 Then
' Predpostavimo, da je kljuc v drugi tabeli v razdelku
Set tbl = rng.Tables(2)

' Preberi priimek in ime iz tabele
If tbl.Rows.Count >= 4 And tbl.Columns.Count >= 2 Then
Debug.Print "Besedilo v celici (4, 2): " & tbl.cell(4, 2).Range.Text
userName = Trim(tbl.cell(4, 2).Range.Text) ' Priimek in ime v isti celici

' Odstrani vse nepotrebne znake, kot so oznake konca vrstic
userName = Replace(userName, Chr(13), "")
userName = Replace(userName, Chr(7), "")
userName = Trim(userName) ' Ponovno trim za vsak slucaj

' Loci priimek in ime - prvi del je priimek, ostalo je ime
nameParts = Split(userName, " ")

If UBound(nameParts) >= 1 Then
lastName = nameParts(0) ' Prvi del je priimek
' Združi preostale dele imena (v primeru vec imen)
firstName = ""
For j = 1 To UBound(nameParts)
firstName = firstName & nameParts(j) & " "
Next j
firstName = Trim(firstName) ' Odstrani odvecne presledke na koncu
Else
Debug.Print "Napaka: Priimek in ime nista pravilno locena."
GoTo NextSection
End If

' Zamenjaj šumnike
lastName = Replace(lastName, "c", "c")
lastName = Replace(lastName, "š", "s")
lastName = Replace(lastName, "ž", "z")
lastName = Replace(lastName, "c", "c")

firstName = Replace(firstName, "c", "c")
firstName = Replace(firstName, "š", "s")
firstName = Replace(firstName, "ž", "z")
firstName = Replace(firstName, "c", "c")

' Nastavi pot do mape in datoteke
folderPath = baseFolderPath & lastName & " " & firstName
filePath = folderPath & "\List evidence_" & lastName & " " & firstName & ".docx"

' Izpiši filePath za razhrošcevanje
Debug.Print "filePath: " & filePath

' Ustvari mapo, ce ne obstaja
If Dir(folderPath, vbDirectory) = "" Then
MkDir folderPath
Debug.Print "Mapa ustvarjena: " & folderPath
End If

' Preveri, ali datoteka že obstaja, in jo izbriši
If Dir(filePath) <> "" Then
Kill filePath
Debug.Print "Stara datoteka izbrisana: " & filePath
End If

' Shrani trenutni razdelek kot nov dokument
rng.Copy
Set newDoc = Documents.Add
newDoc.Content.Paste
newDoc.SaveAs2 fileName:=filePath, FileFormat:=wdFormatDocumentDefault
newDoc.Close
Debug.Print "Dokument shranjen: " & filePath

' Preveri, ali je datoteka dejansko shranjena
If Dir(filePath) <> "" Then
Debug.Print "Datoteka uspešno shranjena: " & filePath
Else
Debug.Print "Napaka pri shranjevanju datoteke: " & filePath
End If
Else
Debug.Print "Tabela v razdelku " & i & " nima dovolj celic."
End If
Else
Debug.Print "Tabela v razdelku " & i & " ne obstaja."
End If
NextSection:
On Error GoTo 0
Next i
End Sub'
Koda se izvaja lepo za vrstice, ki ne vsebujejo č, ć in đ. Ostali šumniki gredo lepo čez. Hvala za možnost in trud in vse dobro.

[admin]

Pozdravljeni,

Kako naj bi vam to delovalo. Vi lepo zamenjate Š in Ž, Č pa nikoli. 2x 'c' zamenjate s 'c', kar nima smisla

Koda: Izberi vse

lastName = Replace(lastName, "c", "c")
lastName = Replace(lastName, "š", "s")
lastName = Replace(lastName, "ž", "z")
lastName = Replace(lastName, "c", "c")

Tole bo prav:

Koda: Izberi vse

lastName = Replace(lastName, "č", "c")
lastName = Replace(lastName, "š", "s")
lastName = Replace(lastName, "ž", "z")

in enako za ime...

[Vikmar]

To sem opazil in sklepal, da je en c za č in drugi c za ć. Zamenjal sem obe črki sprožil makro, ki je nekaj časa mlel, nato se je Word samodejno zaprl in odprl datoteke, ki jih je samoobnovil,Verjetno se je sesul. Je pa odprl v mapi samo eno podmapo s priimkom in imenom prve osebe na listu.Sedaj sem upošteval še vaš popravek in je bil efekt isti. Razmišjam, če je kaj narobe z Office 2016, ki ga uporabljam.