Option Explicit
Sub HL1901PLN()
Dim SArr, Res() As String, Tmp
Dim i, j, k
SArr = Sheet1.Range("A2", Sheet1.Range("A2").End(xlDown))
ReDim Res(1 To UBound(SArr), 1 To 4)
For i = 1 To UBound(SArr)
Tmp = Split(SArr(i, 1))
For j = 2 To UBound(Tmp)
If IsNumeric(Tmp(j)) = True And Len(Tmp(j)) >= 8 Then
k = k + 1
Res(i, k + 1) = Tmp(j)
End If
Next j
For j = UBound(Tmp) To 1 Step -1
If IsNumeric(Tmp(j)) = True And Len(Tmp(j)) = 1 And Len(Tmp(j - 1)) > 1 Then
Res(i, 4) = Tmp(j)
Exit For
End If
Next j
Res(i, 1) = Tmp(0)
k = 0
Next i
Sheet1.Range("B2", Sheet1.Range("E" & UBound(SArr) + 1)).ClearContents
Sheet1.Range("B2", Sheet1.Range("E" & UBound(SArr) + 1)) = Res
End SubThêm dòng này trước End Sub là được bạn.
Sheet1.Range("B2", Sheet1.Range("B1000000").End(xlUp)).NumberFormat = "@"Nhưng bạn cần nếu kết quả mong muốn của bạn trong những trường hợp đó đi chứ.
Bạn chạy thử Sub này xem sao.
Public Sub GPE()
Dim sArr(), dArr(), I As Long, J As Long, N As Long, R As Long, Tmp
sArr = Range("A2", Range("A2").End(xlDown)).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 4)
For I = 1 To R
Tmp = Split(sArr(I, 1), " "): N = UBound(Tmp)
dArr(I, 1) = Tmp(0): dArr(I, 2) = "'" & Tmp(2)
dArr(I, 3) = "'" & Tmp(N - 2): dArr(I, 4) = Tmp(N - 1)
Next I
Range("B2:D2").Resize(R) = dArr
End Subdạ em gửi nhầm file cho anh, em gửi lại file cho anh xem, em có nêu tất cả trường hợp xảy ra, em có nêu kết quả tham khảo đó anh!
Vậy thì xét theo kiểu "lòng vòng".
Sub GPE()
Dim sArr, dArr(), I As Long, J As Long, N As Long, R As Long, Tmp
sArr = Range("A2", Range("A2").End(xlDown)).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 4)
For I = 1 To UBound(sArr)
Tmp = Split(sArr(I, 1)): N = UBound(Tmp)
dArr(I, 1) = Tmp(0): dArr(I, 2) = Tmp(2)
For J = 3 To UBound(Tmp)
If IsNumeric(Tmp(J)) Then
N = J + 1: dArr(I, 3) = Tmp(J)
Exit For
End If
Next J
For J = UBound(Tmp) To N Step -1
If IsNumeric(Tmp(J)) And (Not IsNumeric(Tmp(J - 1)) Or J = N) Then
dArr(I, 4) = Tmp(J): Exit For
End If
Next J
Next I
Range("B2:E2").Resize(R) = dArr
End Sub
