Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
'///////////////////////////////////////////////////////
#If Win64 Then
Private gTimerID As LongPtr, gTimerID2 As LongPtr
#Else
Private gTimerID As Long, gTimerID2 As Long
#End If
'///////////////////////////////////////////////////////
Private NameToCode_OArgs(), NameToCode_OIndex As Integer
Function S_NameToCode(ByVal values As Range, _
Optional ByVal upper As Boolean, _
Optional ByVal Delimiter As String = " ", _
Optional ByVal CodeNumberStart As Long = 0, _
Optional ByVal Format As String = "000") As Variant
On Error Resume Next
KillTimer 0&, gTimerID: gTimerID = 0
'-----------------------------------------------
Dim d As Object
S_NameToCode = NameToCode(CStr(values(1, 1).value), upper, Delimiter, CodeNumberStart, Format, d)
'-----------------------------------------------
If values.Cells.Count > 1 Then
Dim UB As Integer, K As Integer
'-----------------------------------------------
UB = UBound(NameToCode_OArgs, 2): K = UB
K = K + 1
ReDim Preserve NameToCode_OArgs(1 To K)
NameToCode_OArgs(K) = Array(values, upper, Delimiter, CodeNumberStart, Format, d, Application.Caller)
gTimerID = SetTimer(0&, 0&, 1, AddressOf S_NameToCode_callback)
End If
End Function
'///////////////////////////////////////////////////////
Private Sub S_NameToCode_callback()
On Error Resume Next
Call KillTimer(0&, gTimerID): gTimerID = 0
Call KillTimer(0&, gTimerID2): gTimerID2 = 0
On Error GoTo 0
'----------------------------------
Dim UA As Integer
UA = UBound(NameToCode_OArgs)
If UA > 0 Then
NameToCode_OIndex = NameToCode_OIndex + 1
'-------------------------------------------
Dim Args, R As Long, C As Integer, total(), total2(), UB As Long, UB2 As Integer
Dim d As Object, upper As Boolean, Delimiter As String, Format As String, CodeNumberStart As Long
Dim Rng As Range
Args = NameToCode_OArgs(NameToCode_OIndex)
Set Rng = Args(0)
UB = Rng(Rng.Rows.Count + 2, 1).End(3).Row - Rng.Row + 1
If UB > 0 Then
Args(0) = Rng(1, 1).Resize(UB, Rng.Columns.Count).value
Set d = Args(5): upper = Args(1): Delimiter = Args(2): Format = Args(4)
CodeNumberStart = Args(3)
UB2 = UBound(Args(0), 2)
ReDim total(2 To Rng.Rows.Count, 1 To UB2)
For R = 2 To UB
For C = 1 To UB2
If Args(0)(R, C) <> "" Then
total(R, C) = NameToCode(CStr(Args(0)(R, C)), upper, Delimiter, CodeNumberStart, Format, d)
End If
Next
Next
Args(6)(2, 1).Resize(UBound(total) - 1, UB2).value = total
If UB2 > 1 Then
ReDim total2(1 To 1, 2 To UB2)
For C = 2 To UB2
If Args(0)(1, C) <> "" Then
total2(1, C) = NameToCode(CStr(Args(0)(1, C)), upper, Delimiter, CodeNumberStart, Format, d)
End If
Next
Args(6)(1, 2).Resize(, UB2 - 1).value = total2
End If
End If
'-------------------------------------------
If NameToCode_OIndex >= UA Then
Erase NameToCode_OArgs: NameToCode_OIndex = 0
Else
gTimerID = SetTimer(0&, 0&, 1, AddressOf S_NameToCode_callback2)
End If
End If
End Sub
Private Sub S_NameToCode_callback2()
S_NameToCode_callback
End Sub
Function NameToCode(Text As String, _
Optional ByVal upper As Boolean, _
Optional ByVal Delimiter As String = " ", _
Optional ByVal CodeNumberStart As Long = 0, _
Optional ByVal strFormat As String = "000", _
Optional ByRef DList As Object) As Variant
If Text = "" Then NameToCode = "": Exit Function
Dim a As String, e As String, i As String, o As String, u As String, y As String, d As String
a = "[aA" & ChrW(224) & ChrW(225) & ChrW(226) & ChrW(227) & ChrW(259) & ChrW(7841) & ChrW(7843) & ChrW(7845) & ChrW(7847) & ChrW(7849) & ChrW(7851) & ChrW(7853) & ChrW(7855) & ChrW(7857) & ChrW(7859) & ChrW(7861) & ChrW(7863) & ChrW(65) & ChrW(192) & ChrW(193) & ChrW(194) & ChrW(195) & ChrW(258) & ChrW(7840) & ChrW(7842) & ChrW(7844) & ChrW(7846) & ChrW(7848) & ChrW(7850) & ChrW(7852) & ChrW(7854) & ChrW(7856) & ChrW(7858) & ChrW(7860) & ChrW(7862) & "]"
e = "[eE" & ChrW(232) & ChrW(233) & ChrW(234) & ChrW(7865) & ChrW(7867) & ChrW(7869) & ChrW(7871) & ChrW(7873) & ChrW(7875) & ChrW(7877) & ChrW(7879) & ChrW(200) & ChrW(201) & ChrW(202) & ChrW(7864) & ChrW(7866) & ChrW(7868) & ChrW(7870) & ChrW(7872) & ChrW(7874) & ChrW(7876) & ChrW(7878) & "]"
i = "[iI" & ChrW(236) & ChrW(237) & ChrW(297) & ChrW(7881) & ChrW(7883) & ChrW(204) & ChrW(205) & ChrW(296) & ChrW(7880) & ChrW(7882) & "]"
o = "[oO" & ChrW(242) & ChrW(243) & ChrW(244) & ChrW(245) & ChrW(417) & ChrW(7885) & ChrW(7887) & ChrW(7889) & ChrW(7891) & ChrW(7893) & ChrW(7895) & ChrW(7897) & ChrW(7899) & ChrW(7901) & ChrW(7903) & ChrW(7905) & ChrW(7907) & ChrW(210) & ChrW(211) & ChrW(212) & ChrW(213) & ChrW(416) & ChrW(7884) & ChrW(7886) & ChrW(7888) & ChrW(7890) & ChrW(7892) & ChrW(7894) & ChrW(7896) & ChrW(7898) & ChrW(7900) & ChrW(7902) & ChrW(7904) & ChrW(7906) & "]"
u = "[uU" & ChrW(249) & ChrW(250) & ChrW(361) & ChrW(432) & ChrW(7909) & ChrW(7911) & ChrW(7913) & ChrW(7915) & ChrW(7917) & ChrW(7919) & ChrW(7921) & ChrW(217) & ChrW(218) & ChrW(360) & ChrW(431) & ChrW(7908) & ChrW(7910) & ChrW(7912) & ChrW(7914) & ChrW(7916) & ChrW(7918) & ChrW(7920) & "]"
y = "[yY" & ChrW(253) & ChrW(7923) & ChrW(7925) & ChrW(7927) & ChrW(7929) & ChrW(221) & ChrW(7922) & ChrW(7924) & ChrW(7926) & ChrW(7928) & "]"
d = "[dD" & ChrW(273) & ChrW(272) & "]"
Dim S1 As String, S2 As String, s As String, SP() As String
Dim L1 As Integer, L2 As Integer
SP = Split(Text, Delimiter): L2 = UBound(SP)
For L1 = 0 To L2
S1 = LCase(Left(SP(L1), 1))
Select Case True
Case S1 Like a: S1 = "a"
Case S1 Like e: S1 = "e"
Case S1 Like i: S1 = "i"
Case S1 Like o: S1 = "o"
Case S1 Like u: S1 = "u"
Case S1 Like y: S1 = "y"
Case S1 Like d: S1 = "d"
End Select
SP(L1) = S1
Next
S2 = Join(SP, ""):
If DList Is Nothing Then
Set DList = VBA.CreateObject("Scripting.Dictionary")
DList.compareMode = 1
Else
While DList.exists(S2 & Format(CodeNumberStart, strFormat))
CodeNumberStart = CodeNumberStart + 1
Wend
End If
NameToCode = S2 & Format(CodeNumberStart, "000")
If upper Then NameToCode = UCase(NameToCode)
DList(NameToCode) = CodeNumberStart
End Function