Sub TachChuoi()
Dim Nguon
Dim Mang, So, Stt
Dim Kq
Dim i, j, k, x, z, t
Nguon = Sheet1.Range("A6", Sheet1.Range("A6").End(xlDown))
ReDim Kq(1 To UBound(Nguon), 1 To 6)
With CreateObject("VbScript.RegExp")
.Global = True
.Pattern = ".*([A-Z]\D+)(\d*)"
For i = 1 To UBound(Nguon)
Nguon(i, 1) = WorksheetFunction.Trim(Replace(Nguon(i, 1), ".", ""))
Mang = Split(Nguon(i, 1))
If IsNumeric(Mang(0)) = True Then
Stt = Stt + 1
Kq(Stt, 1) = Mang(0)
Mang(0) = ""
k = UBound(Mang)
If IsNumeric(Mang(k)) = True Then
Kq(Stt, 6) = CLng(Mang(k))
Mang(k) = ""
If IsNumeric(Mang(k - 1)) = True Then
Kq(Stt, 5) = Mang(k - 1)
Mang(k - 1) = ""
If IsNumeric(Mang(k - 2)) Then
Kq(Stt, 4) = Mang(k - 2)
Mang(k - 2) = ""
Kq(Stt, 3) = .Replace(Mang(k - 3), "$1")
Mang(k - 3) = Left(Mang(k - 3), InStr(Mang(k - 3), Kq(Stt, 3)) - 1)
Else
If .test(Mang(k - 2)) Then
Kq(Stt, 4) = .Replace(Mang(k - 2), "$2")
Kq(Stt, 3) = .Replace(Mang(k - 2), "$1")
Mang(k - 2) = Left(Mang(k - 2), InStr(Mang(k - 2), Kq(Stt, 3)) - 1)
End If
End If
Else
If .test(Mang(k - 1)) Then
So = .Replace(Mang(k - 1), "$2")
j = Len(So)
For x = 1 To Len(So) - 1
z = Int(So / 10 ^ (j - x))
t = So - 10 ^ (j - x)
If z * t = Kq(Stt, 6) Then
Kq(Stt, 5) = t
Kq(Stt, 4) = z
Kq(Stt, 3) = .Replace(Mang(k - 1), "$1")
Mang(k - 1) = Left(Mang(k - 1), InStr(Mang(k - 1), Kq(Stt, 3)) - 1)
Exit For
End If
Next x
End If
End If
End If
Kq(Stt, 2) = WorksheetFunction.Trim(Join(Mang))
Else
Kq(Stt, 2) = Kq(Stt, 2) & " " & Trim(Nguon(i, 1))
End If
Next i
End With
With Sheet1
.Range("M6").Resize(UBound(Kq), UBound(Kq, 2)).Clear
.Range("M6").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
.Range("M6").Resize(UBound(Kq), UBound(Kq, 2)).Columns.AutoFit
.Range("M6").Resize(UBound(Kq), UBound(Kq, 2)).Borders.LineStyle = 1
End With
End Sub
