Hallo Joachim,
hier ein Code, der alle Unicode-Zeiche durch gleiche/ähnliche ANSI-255 Code Zeichen ersetzt.
In der Datei ist die zugehörige Übersetzungstabelle.
https://www.herber.de/bbs/user/53187.xls
Gruß
Franz
Sub ConvertUnicode()
' konvertiert Unicode-Zeichen in ANSI-255
Dim i As Long
Dim objZelle As Range
Dim strText As String, strNeu As String
Application.ScreenUpdating = False
For Each objZelle In ActiveSheet.UsedRange
If Not (objZelle.HasFormula Or objZelle.HasArray Or IsError(objZelle) _
Or IsEmpty(objZelle) Or IsNumeric(objZelle) Or IsDate(objZelle)) Then
strText = objZelle.Value
For i = 1 To Len(strText)
Select Case AscW(Mid(strText, i, 1)) 'Unicod-Nummer
Case 32 To 126 'ASC = Unicode-Nummer
strNeu = strNeu & Mid(strText, i, 1)
Case 160 To 255 'ASC = Unicode-Nummer
strNeu = strNeu & Mid(strText, i, 1)
Case 256 To 305, 308 To 311, 313 To 328, 332 To 382, 402, _
416, 417, 431, 432, 461 To 476
'Automatisch Unicode to Asc
strNeu = strNeu & Chr$(Asc(Mid(strText, i, 1)))
Case 306 'Sonderzeichen
strNeu = strNeu & "IJ"
Case 307 'Sonderzeichen
strNeu = strNeu & "iJ"
Case 312 'Sonderzeichen wie K
strNeu = strNeu & "K"
Case 329 'Sonderzeichen wie n
strNeu = strNeu & "n"
Case 330, 331, 399, 601
'Sonderzeichen ohne passendes ASCII-255 Zeichen
strNeu = strNeu & "?"
Case 506 'Sonderzeichen Å
strNeu = strNeu & Chr(197)
Case 507 'Sonderzeichen å
strNeu = strNeu & Chr(229)
Case 508 'Sonderzeichen Æ
strNeu = strNeu & Chr(198)
Case 509 'Sonderzeichen æ
strNeu = strNeu & Chr(230)
Case 510 'Sonderzeichen wie Ø
strNeu = strNeu & Chr(216)
Case 511 'Sonderzeichen ø
strNeu = strNeu & Chr(248)
Case 7808, 7810, 7812 'Sonderzeichen wie W
strNeu = strNeu & "W"
Case 7809, 7811, 7813 'Sonderzeichen wie w
strNeu = strNeu & "w"
Case 7840, 7842, 7844, 7846, 7848, 7850, 7852, 7854, 7856, 7860, 7862
'Sonderzeichen wie A
strNeu = strNeu & "A"
Case 7858 'Sonderzeichen Å
strNeu = strNeu & Chr(197)
Case 7841, 7843, 7845, 7847, 7849, 7851, 7853, 7855, 7857, 7859, 7861, 7863
'Sonderzeichen wie a
strNeu = strNeu & "a"
Case 7864, 7866, 7868, 7870, 7872, 7874, 7876, 7878 'Sonderzeichen wie E
strNeu = strNeu & "E"
Case 7865, 7867, 7869, 7871, 7873, 7875, 7877, 7879 'Sonderzeichen wie e
strNeu = strNeu & "e"
Case 7880, 7882 'Sonderzeichen wie I
strNeu = strNeu & "I"
Case 7881, 7883 'Sonderzeichen wie i
strNeu = strNeu & "i"
Case 7884, 7886, 7888, 7890, 7892, 7894, 7896, 7898, 7900, 7902, 7904, 7906
'Sonderzeichen wie O
strNeu = strNeu & "O"
Case 7885, 7887, 7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907
'Sonderzeichen wie o
strNeu = strNeu & "o"
Case 7908, 7910, 7912, 7914, 7916, 7918, 7920 'Sonderzeichen wie U
strNeu = strNeu & "U"
Case 7909, 7911, 7913, 7915, 7917, 7919, 7921 'Sonderzeichen wie u
strNeu = strNeu & "u"
Case 7922, 7924, 7926, 7928 'Sonderzeichen wie Y
strNeu = strNeu & "Y"
Case 7923, 7925, 7927, 7929 'Sonderzeichen wie y
strNeu = strNeu & "y"
Case Else
strNeu = strNeu & Mid(strText, i, 1) 'Zeichen wird übernommen zb. Zeilenschaltungen
End Select
Next
objZelle.Value = strNeu
strNeu = ""
End If
Next
Application.ScreenUpdating = True
End Sub