Makro v Excelu pro odstranění diakritiky

Potřeboval jsem odstranit diakritiku u cca 100 řádků excelovské tabulky (a nechtělo se mi všechny položky ručně přepisovat B) ).

A tak jsem pátral po netu a našel jsem co jsem potřeboval :) v diskuzi na Technetu.

Upravil jsem zdrojový kód, tak aby byl použitelný na označenou oblast (ideálně uložit do personal.xlsb popř. do jiného souboru osobních :) maker).

náhled zdrojového kódu
Sub OdstranDiakritiku()
 
Const cz As String = "áÁčČďĎéÉěĚíÍňŇóÓřŘšŠťŤúÚůŮýÝžŽÄ伾Ôô"
Const en As String = "aAcCdDeEeEiInNoOrRsStTuUuUyYzZAaLlOo"
 
Dim TmpS As String
 
 For Each A In Selection
 
        If A.Value <> "" Then
            OutS = ""
             For I = 1 To Len(A.Value)
              TmpS = Mid(A.Value, I, 1)
              If InStr(1, cz, TmpS, vbBinaryCompare) > 0 Then
               TmpS = Mid(en, InStr(1, cz, TmpS, vbBinaryCompare), 1)
              End If
              OutS = OutS & TmpS
             Next I
           A.Value = OutS
 
        End If
 Next
 
End Sub

8 komentářů

el
před třemi lety
reagovat
Pěkné. Dej si akorat pozor aby jsi v datech neměl žádného Müllera nebo Máo Zédōnga \:\)
zmt
před třemi lety
reagovat
\:\) no je fakt, že třebas ve jménech bude asi Máo Zédōngů stále více ;\)
Viktor Fuka
před třemi lety
reagovat
Pěkné, ale v excelu 2010 to nefunguje. Chyby to hlásí na řádku

If A.Value <> “” Then

…..
If InStr(1, cz, TmpS, vbBinaryCompare) > 0 Then
….
OutS = OutS & TmpS

podle mě kvůli <>&

nevíte co s tím?
zmt
před třemi lety
reagovat
Tak teď by to mělo fungovat, WP mi převedl <> na “bezpečné znaky” <>
Stoupa
před dvěma lety
reagovat
A co tohle? =diakritika(A1) Lze využít jako vlastní vzorec

Function diakritika(source As Variant) As String

Const cz As String = “áÁčČďĎéÉěĚëËíÍňŇóÓöÖřŘšŠťŤúÚůŮüÜýÝžŽ”
Const en As String = “aAcCdDeEeEeEiInNoOoOrRsStTuUuUuUyYzZ”

Dim TmpS As String
Dim OutS As String

Dim I As Integer

OutS = “”
If IsNull(source) Or source = “” Then
diakritika = “”
Else
For I = 1 To Len(source)
TmpS = Mid(source, I, 1)
If InStr(1, cz, TmpS, vbBinaryCompare) > 0 Then TmpS = Mid(en, InStr(1, cz, TmpS, vbBinaryCompare), 1)
OutS = OutS & TmpS
Next I
diakritika = OutS
End If

End Function
zmt
před dvěma lety
reagovat
Použití jako vzorec, je další možnost Já raději používám “selection” přijde mi to rychlejší (v kombinaci s kl. zkratkou).
anonym
před rokem
reagovat
chybi makke L
zmt
před rokem
reagovat
Doplnil jsem pár písmen ze slovenké abecedy (moc jí nepoužívám ;\)). Jinak makro je velmi jednoduché a pokud si chceš přidat další písmeno, stačí ho doplnit do proměnné cz s diakritikou a oproti tomu do prom. en bez diakritiky.

Přidejte komentář

Text komentáře musí být zadán, ostatní údaje nejsou povinné. HTML tagy nejsou povoleny.

Captcha picture.