Nhờ các anh chị giúp Em có bảng dữ liệu cần lấy dự liệu text

[goldsea]

Nhờ các anh chị giúp. Em có bảng dữ liệu text xuất từ một phần mềm ra trong các ô text đó em cần lấy một số dự liệu tách riêng cột em bôi vàng
Em xin cảm ơn
LH vhduong@gmail.com
0912007875

 

[bebo021999]

Tạo 1 sheet "tach" để lưu dữ liệu sau khi tách.
Nhất nút "TÁCH" rồi qua sheet "tach" kiểm tra

Option Explicit
Sub test()
Dim rng, lr&, i&, j&, t&, k&, sp, s, c&, arr(1 To 1000, 1 To 100)
With Sheets("Sheet1")
    rng = .Range("A1:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
For j = 1 To UBound(rng, 2)
    k = 0
    For i = 1 To UBound(rng)
        sp = Split(rng(i, j), Chr(10))
        For t = 1 To IIf(UBound(sp) < 4, UBound(sp), 4)
            Do
                sp(t) = Replace(sp(t), "  ", " ")
                c = InStr(1, sp(t), "  ")
            Loop Until c = 0
            Select Case t
                Case 1
                    c = InStr(1, sp(t), " NAME-")
                    If c > 0 Then
                        k = k + 1
                        arr(k, j) = CStr(Left(sp(t), c - 1))
                        k = k + 1
                        arr(k, j) = Mid(sp(t), c + 6, 255)
                    End If
                Case 2
                    c = InStrRev(sp(t), "-")
                    If c > 0 Then
                        k = k + 1
                        arr(k, j) = Mid(sp(t), c + 1, 255)
                    End If
                Case 4
                    s = Split(sp(t), " ")
                    k = k + 1: arr(k, j) = s(2) & " " & s(3)
                    k = k + 1: arr(k, j) = s(5)
                    k = k + 1: arr(k, j) = s(6) & " " & s(7)
            End Select
        Next
        k = k + 1
    Next
Next
With Sheets("tach")
    .Cells.ClearContents
    .Range("A1").Resize(k, 3).Value = arr
End With
End Sub