[Help] VBA phân Group theo sheet điều kiện

[ngoctuyen1995]

Thân chào cả nhà GPEX,

Mong cả nhà giúp em một việc ạ.
Hiện tại em có 01 file data bao gồm 02 sheet (Data và Dieu Kien).
Em muốn dùng VBA để phần Group ở sheet Data dựa vào cột A (Company Name) tương ứng với các từ ở Sheet Dieu kien (Name) và note vào cột Group ở sheet Data.
vì số lượng data của em lên đến ~100 nghìn dòng nếu search từng điều kiện để note thì khá tốn thời gian và dễ sai sót.
Mong cả nhà giúp đỡ em (em có đính kèm file và một số Data mẫu).
Em chân thành cảm ơn ạ.!

 

[Ba Tê]

Thân chào cả nhà GPEX,

Mong cả nhà giúp em một việc ạ.
Hiện tại em có 01 file data bao gồm 02 sheet (Data và Dieu Kien).
Em muốn dùng VBA để phần Group ở sheet Data dựa vào cột A (Company Name) tương ứng với các từ ở Sheet Dieu kien (Name) và note vào cột Group ở sheet Data.
vì số lượng data của em lên đến ~100 nghìn dòng nếu search từng điều kiện để note thì khá tốn thời gian và dễ sai sót.
Mong cả nhà giúp đỡ em (em có đính kèm file và một số Data mẫu).
Em chân thành cảm ơn ạ.!

Bạn sửa lại tiêu đề, bỏ cái [Help] đi, đang trao đổi với người Việt lại "xía" tiếng "tào lao" vào làm cho nhiều người ngứa mắt.
Bạn thử với Sub này, số lượng hàng trăm ngàn dòng chưa biết chạy bao lâu.
Chú ý dòng Option Compare Text

Option Explicit
Option Compare Text

Public Sub Lubu()
Dim sArr(), dArr(), tArr(), Txt As String
Dim I As Long, J As Long, R1 As Long, R2 As Long
    tArr = Sheets("Dieu kien").Range("A2", Sheets("Dieu kien").Range("B1000").End(xlUp)).Value
    R2 = UBound(tArr)
With Sheets("Data")
    sArr = .Range("A2", .Range("A1000000").End(xlUp)).Value
    R1 = UBound(sArr)
    ReDim dArr(1 To R1, 1 To 1)
    For I = 1 To R1
        Txt = sArr(I, 1)
        For J = 1 To R2
            If InStr(Txt, tArr(J, 1)) Then
                dArr(I, 1) = tArr(J, 2)
                Exit For
            End If
        Next J
    Next I
    .Range("L2").Resize(R1) = dArr
End With
End Sub

 

[ngoctuyen1995]

Bạn sửa lại tiêu đề, bỏ cái [Help] đi, đang trao đổi với người Việt lại "xía" tiếng "tào lao" vào làm cho nhiều người ngứa mắt.
Bạn thử với Sub này, số lượng hàng trăm ngàn dòng chưa biết chạy bao lâu.
Chú ý dòng Option Compare Text

Option Explicit
Option Compare Text

Public Sub Lubu()
Dim sArr(), dArr(), tArr(), Txt As String
Dim I As Long, J As Long, R1 As Long, R2 As Long
    tArr = Sheets("Dieu kien").Range("A2", Sheets("Dieu kien").Range("B1000").End(xlUp)).Value
    R2 = UBound(tArr)
With Sheets("Data")
    sArr = .Range("A2", .Range("A1000000").End(xlUp)).Value
    R1 = UBound(sArr)
    ReDim dArr(1 To R1, 1 To 1)
    For I = 1 To R1
        Txt = sArr(I, 1)
        For J = 1 To R2
            If InStr(Txt, tArr(J, 1)) Then
                dArr(I, 1) = tArr(J, 2)
                Exit For
            End If
        Next J
    Next I
    .Range("L2").Resize(R1) = dArr
End With
End Sub

Em cảm ơn Anh, Code khá nhanh và đúng ý em ạ.
Chúc anh sức khỏe và thành công ạ.