Tách tên công ty trong chuỗi excel

[DOTEXCEL2010]

Dạ em nhờ A/C diễn đàn hỗ trợ giúp e với ạ.
Việc là e có cột dữ liệu trong đó có Tên Công ty e cần tách ra 1 một riêng. nhưng do chuỗi đó không có nguyên tắc chung trước và sau chuỗi cần tách nên em chưa tìm được cách. Em up file đính kèm lên nhờ Anh Chị giúp em với ạ.
Cảm ơn A/C nhiều.

 

[HUONGHCKT]

Dạ em nhờ A/C diễn đàn hỗ trợ giúp e với ạ.
Việc là e có cột dữ liệu trong đó có Tên Công ty e cần tách ra 1 một riêng. nhưng do chuỗi đó không có nguyên tắc chung trước và sau chuỗi cần tách nên em chưa tìm được cách. Em up file đính kèm lên nhờ Anh Chị giúp em với ạ.
Cảm ơn A/C nhiều.

Trong khi chờ đợi, bạn tham khảo code sau:

Option Explicit

Sub Tach()
Dim i&, j&, Lr&, t&, k&, R&, N&
Dim Arr(), KQ(), S, M, iType As String
With Sheet2
Lr = .Cells(10000, 1).End(xlUp).Row
Arr = .Range("B2:B" & Lr).Value
R = UBound(Arr)
ReDim KQ(1 To UBound(Arr), 1 To 1)
For i = 1 To R
k = 0
  M = Trim(UCase(Arr(i, 1)))
    If InStr(1, M, "CTY") > 0 Then t = InStr(1, M, "CTY"): GoTo Run
    If InStr(1, M, "CT") > 0 Then t = InStr(1, M, "CT"): GoTo Run
    If InStr(1, M, "CONG TY") > 0 Then t = InStr(1, M, "CONG TY"): GoTo Run Else GoTo Run2
Run:
    If InStr(1, M, "TT") > 0 And InStr(1, M, "TT") > t Then
        k = InStr(1, M, "TT") - 1: GoTo Run1
    ElseIf --InStr(1, M, "CK") > 0 And InStr(1, M, "CK") > t Then
        k = InStr(1, M, "CK") - 1: GoTo Run1
    ElseIf --InStr(1, M, "TK") > 0 And InStr(1, M, "TK") > t Then
        k = InStr(1, M, "TK") - 1: GoTo Run1
    Else
        S = Split(M, " ")
            For j = UBound(S) To 0 Step -1
                If IsNumeric(S(j)) Then If InStr(1, M, S(j)) > t Then k = InStr(1, M, S(j)) - 1: GoTo Run1
            Next j
        If k = 0 Then
            k = Len(M) + 1: GoTo Run1
        End If
    End If
Run1:
    If t Then KQ(i, 1) = Mid(M, t, k - t)
Run2:
Next i
.Range("F2").Resize(R, 1) = KQ
End With
End Sub

Lưu ý: Code này chạy ra kết quả đúng được gần 100% các bản ghi như trong file đã đăng. (hiện tại mới chỉ tìm thấy 3 dấu hiệu kết thúc tên công ty)
Xem file. (kết quả chạy code đang để ở cột F)

 

[DOTEXCEL2010]

Trong khi chờ đợi, bạn tham khảo code sau:

Option Explicit

Sub Tach()
Dim i&, j&, Lr&, t&, k&, R&, N&
Dim Arr(), KQ(), S, M, iType As String
With Sheet2
Lr = .Cells(10000, 1).End(xlUp).Row
Arr = .Range("B2:B" & Lr).Value
R = UBound(Arr)
ReDim KQ(1 To UBound(Arr), 1 To 1)
For i = 1 To R
k = 0
  M = Trim(UCase(Arr(i, 1)))
    If InStr(1, M, "CTY") > 0 Then t = InStr(1, M, "CTY"): GoTo Run
    If InStr(1, M, "CT") > 0 Then t = InStr(1, M, "CT"): GoTo Run
    If InStr(1, M, "CONG TY") > 0 Then t = InStr(1, M, "CONG TY"): GoTo Run Else GoTo Run2
Run:
    If InStr(1, M, "TT") > 0 And InStr(1, M, "TT") > t Then
        k = InStr(1, M, "TT") - 1: GoTo Run1
    ElseIf --InStr(1, M, "CK") > 0 And InStr(1, M, "CK") > t Then
        k = InStr(1, M, "CK") - 1: GoTo Run1
    ElseIf --InStr(1, M, "TK") > 0 And InStr(1, M, "TK") > t Then
        k = InStr(1, M, "TK") - 1: GoTo Run1
    Else
        S = Split(M, " ")
            For j = UBound(S) To 0 Step -1
                If IsNumeric(S(j)) Then If InStr(1, M, S(j)) > t Then k = InStr(1, M, S(j)) - 1: GoTo Run1
            Next j
        If k = 0 Then
            k = Len(M) + 1: GoTo Run1
        End If
    End If
Run1:
    If t Then KQ(i, 1) = Mid(M, t, k - t)
Run2:
Next i
.Range("F2").Resize(R, 1) = KQ
End With
End Sub

Lưu ý: Code này chạy ra kết quả đúng được gần 100% các bản ghi như trong file đã đăng. (hiện tại mới chỉ tìm thấy 3 dấu hiệu kết thúc tên công ty)
Xem file. (kết quả chạy code đang để ở cột F)

Cảm ơn Anh rất nhiều. Vậy cũng tốt lắm rồi Anh