Sub Tach()
Dim RE As Object, i As Long, k As Long, ik As Long, t As Integer, j As Integer
Dim S As String, S1 As String, S2 As String, Rng As Range
Dim L1 As Integer, L2 As Integer
On Error Resume Next
Set RE = VBA.CreateObject("VBScript.RegExp")
With RE
.Global = True
.IgnoreCase = True
.Pattern = "([^\u4e00-\u9eff]*)([^\uac00-\ud7af]*[,\/. ]*[^\uac00-\ud7af]*)(.*)"
End With
Set Rng = Range("A2").Resize(Range("A" & Rows.Count).End(3).Row)
Dim a, aa(), sp$(), ij As Boolean
a = Rng.Value
ReDim aa(1 To UBound(a), 1 To 6)
For i = 1 To UBound(a)
L1 = Len(a(i, 1))
If IsNumeric(Left(a(i, 1), 2)) Then
S = a(i, 1)
If i < UBound(a) Then
ij = Not IsNumeric(Left(a(i + 1, 1), 2))
If ij Then S = S & " " & a(i + 1, 1)
End If
ik = i - k
L2 = Len(S)
S2 = Replace(S, " ", "")
If L2 - Len(S2) = 6 Then
t = 0: t = InStr(S, ". ")
aa(ik, 2) = Left(S, t)
sp = Split(Mid(S, t + 2), " ")
For j = 3 To 6
aa(ik, j) = sp(j - 3)
Next
Else
t = 0: t = InStr(S, " ")
If t Then
S1 = Left(S, t - 1)
S2 = Mid(S, t + 2)
t = 0: t = InStr(a(i, 1), ".")
aa(ik, 2) = Left(S1, t - 1)
aa(ik, 3) = Mid(S1, t + 2)
If RE.test(S2) Then
With RE.Execute(S2)(0)
aa(ik, 4) = VBA.Trim(.SubMatches(0))
aa(ik, 5) = VBA.Trim(.SubMatches(1))
aa(ik, 6) = VBA.Trim(.SubMatches(2))
End With
End If
End If
End If
aa(ik, 1) = S
If ij Then ij = False: k = k + 1
End If
Next i
Rng(1, 2).Resize(UBound(a), 6) = aa
End Sub
