Public dic As Object
Function RemoveMarks(ByVal Text As String) As String
Dim CharCode, i As Long
Dim sTmp As String, sChr As String
On Error Resume Next
sTmp = Text
If dic Is Nothing Then
Set dic = CreateObject("Scripting.Dictionary")
CharCode = Array(7855, 7857, 7859, 7861, 7863, 7845, 7847, 7849, 7851, 7853, 225, _
224, 7843, 227, 7841, 259, 226, 273, 7871, 7873, 7875, 7877, 7879, _
233, 232, 7867, 7869, 7865, 234, 237, 236, 7881, 297, 7883, 7889, _
7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907, 243, 242, _
7887, 245, 7885, 244, 417, 7913, 7915, 7917, 7919, 7921, 250, _
249, 7911, 361, 7909, 432, 253, 7923, 7927, 7929, 7925)
Const ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"
For i = 0 To UBound(CharCode)
dic.Add ChrW(CharCode(i)), Mid(ResText, i + 1, 1)
dic.Add UCase(ChrW(CharCode(i))), UCase(Mid(ResText, i + 1, 1))
Next
End If
For i = 1 To Len(sTmp)
sChr = Mid(sTmp, i, 1)
If dic.Exists(sChr) Then sTmp = Replace(sTmp, sChr, dic.Item(sChr))
Next
RemoveMarks = sTmp
End Function
Sub Main()
Dim txtFile As String, vFile, tmp
Dim fso As Object
Dim arr, aRes()
Dim lR As Long, lRs As Long, t As Double
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
vFile = Application.GetOpenFilename("Text Files, *.txt")
If TypeName(vFile) = "String" Then
t = Timer
txtFile = CStr(vFile)
Application.StatusBar = "Processing data. Please wait..."
With fso.OpenTextFile(txtFile, 1, , -1)
tmp = Trim(.ReadAll)
.Close
End With
If Len(tmp) Then
arr = Split(tmp, vbCrLf)
lRs = UBound(arr) + 1
ReDim aRes(1 To lRs, 1 To 2)
For lR = 1 To lRs - 1
tmp = Split(arr(lR - 1), "|")
aRes(lR, 1) = tmp(0)
aRes(lR, 2) = RemoveMarks(tmp(0))
Next
End If
Application.StatusBar = "Put data to spreadsheet. Please wait..."
Range("A1:B1").Resize(lRs).Value = aRes
MsgBox "Done!", , Format(Timer - t, "0.000")
End If
Set fso = Nothing
Application.StatusBar = ""
End Sub
