[Giúp] VBA Tìm kiếm và nối các range lại với nhau..! (1 người xem)

[robinhsoon]

Xin chào cả Nhà GPE!

Hiện em đang gặp một vấn đề khó mong cả nhà giúp đỡ em hoàn thành dự án này ạ...

Hiện tại em có một File gồm 3 cột (Code, Name, Check)
Công việc là: đầu tiên sort lại cột code, tìm kiếm những code bị trùng nhau sau đó nối các giá trị của cột Name lại với nhau sang bên cột Check (cột Check là cột chứa giá trị nối của cột Name)... Sau khi lấy được cột check thì sẽ xóa các code bị trùng..

Ví dụ: Cột code có 3 code 64306340 trùng nhau, Cột Name có giá trị A, B, C thì cột Check sẽ chứa giá trị là "tai sao store nay khong co hien dien cua A, B, C".

trong file em có làm mẫu ý của mình..!
Mong cả nhà giúp em ạ..! Cảm ơn cả nhà nhiều.!

 

[lehuong1409]

Xin chào cả Nhà GPE!

Hiện em đang gặp một vấn đề khó mong cả nhà giúp đỡ em hoàn thành dự án này ạ...

Hiện tại em có một File gồm 3 cột (Code, Name, Check)
Công việc là: đầu tiên sort lại cột code, tìm kiếm những code bị trùng nhau sau đó nối các giá trị của cột Name lại với nhau sang bên cột Check (cột Check là cột chứa giá trị nối của cột Name)... Sau khi lấy được cột check thì sẽ xóa các code bị trùng..

Ví dụ: Cột code có 3 code 64306340 trùng nhau, Cột Name có giá trị A, B, C thì cột Check sẽ chứa giá trị là "tai sao store nay khong co hien dien cua A, B, C".

trong file em có làm mẫu ý của mình..!
Mong cả nhà giúp em ạ..! Cảm ơn cả nhà nhiều.!

bạn kiểm tra file nhé

 

[robinhsoon]

bạn kiểm tra file nhé

Cảm ơn Thầy đã giúp đỡ em ạ..!
trong code của thầy mình viết để dùng hàm ạ..! em muốn mình dùng Sub để cho nó tự chạy được không Thầy.. và ghép được chuỗi thì nó sẽ tự xóa các code bị trùng luôn ạ...
Mong Thầy giúp đỡ..! Cảm ơn Thầy nhiều ạ.

 

[lehuong1409]

Cảm ơn Thầy đã giúp đỡ em ạ..!
trong code của thầy mình viết để dùng hàm ạ..! em muốn mình dùng Sub để cho nó tự chạy được không Thầy.. và ghép được chuỗi thì nó sẽ tự xóa các code bị trùng luôn ạ...
Mong Thầy giúp đỡ..! Cảm ơn Thầy nhiều ạ.

Thế bạn gửi file đầy đủ lên đi, bao gồm cả trùng, sub thì dữ liệu của bạn nó phải có vị trí cột đúng như thế còn nếu k bạn phải biết cách chỉnh code cho hợp với bài của mình, hàm thì linh hoạt hơn vì dữ liệu thay đổi nó sẽ thay đổi theo luôn

 

[lehuong1409]

P/s đừng gọi mình là thầy nhá. Mình có biết gì đâu cứ gọi bạn hoặc chị thôi

 

[robinhsoon]

P/s đừng gọi mình là thầy nhá. Mình có biết gì đâu cứ gọi bạn hoặc chị thôi

Hi!
Em cảm ơn ạ..Em gửi File đầy đủ của mình ạ! Data của chỉ bao gồm 03 cột đó thôi ạ..

 

[Ba Tê]

Hi!
Em cảm ơn ạ..Em gửi File đầy đủ của mình ạ! Data của chỉ bao gồm 03 cột đó thôi ạ..

Xuất kết quả ra chỗ khác cho bạn kiểm tra nhé. Sau đó bạn muốn cho nó ở đâu thì tùy chỉnh lại.

Public Sub GPE_Ghep()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Tem As String, Txt As String, Rws As Long
sArr = Range("A2", Range("B2").End(xlDown)).Value
R = UBound(sArr): ReDim dArr(1 To R, 1 To 2)
Txt = "Tai sao ......... "
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        Tem = sArr(I, 1)
        If Not .Exists(Tem) Then
            K = K + 1: .Item(Tem) = K
            dArr(K, 1) = Tem: dArr(K, 2) = sArr(I, 2)
        Else
            Rws = .Item(Tem)
            If InStr(dArr(Rws, 2), Txt) = 0 Then dArr(Rws, 2) = Txt & dArr(Rws, 2)
            dArr(Rws, 2) = dArr(Rws, 2) & ", " & sArr(I, 2)
        End If
    Next I
End With
Range("E2:F1000").ClearContents
Range("E2:F2").Resize(K) = dArr
End Sub

 

[robinhsoon]

Xuất kết quả ra chỗ khác cho bạn kiểm tra nhé. Sau đó bạn muốn cho nó ở đâu thì tùy chỉnh lại.

Public Sub GPE_Ghep()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Tem As String, Txt As String, Rws As Long
sArr = Range("A2", Range("B2").End(xlDown)).Value
R = UBound(sArr): ReDim dArr(1 To R, 1 To 2)
Txt = "Tai sao ......... "
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        Tem = sArr(I, 1)
        If Not .Exists(Tem) Then
            K = K + 1: .Item(Tem) = K
            dArr(K, 1) = Tem: dArr(K, 2) = sArr(I, 2)
        Else
            Rws = .Item(Tem)
            If InStr(dArr(Rws, 2), Txt) = 0 Then dArr(Rws, 2) = Txt & dArr(Rws, 2)
            dArr(Rws, 2) = dArr(Rws, 2) & ", " & sArr(I, 2)
        End If
    Next I
End With
Range("E2:F1000").ClearContents
Range("E2:F2").Resize(K) = dArr
End Sub

Em cảm ơn Anh ạ, kết quả thì đúng rồi ạ... Nhưng những code không bị trùng thị lại không có chữ Tại sao..... ở đầu dòng ạ...? nếu em muốn những code chỉ có 01 code có chữ Tại sao..... thì em sửa chỗ nào ạ...

 

[Ba Tê]

Em cảm ơn Anh ạ, kết quả thì đúng rồi ạ... Nhưng những code không bị trùng thị lại không có chữ Tại sao..... ở đầu dòng ạ...? nếu em muốn những code chỉ có 01 code có chữ Tại sao..... thì em sửa chỗ nào ạ...

Lúc đầu đã viết như vậy, nhưng thấy có 1 mã cũng có "tai sao....." nhìn "dô dziêng".

Public Sub GPE_Ghep()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Tem As String, Txt As String, Rws As Long
sArr = Range("A2", Range("B2").End(xlDown)).Value
R = UBound(sArr): ReDim dArr(1 To R, 1 To 2)
Txt = "Tai sao ......... "
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        Tem = sArr(I, 1)
        If Not .Exists(Tem) Then
            K = K + 1: .Item(Tem) = K
            dArr(K, 1) = Tem: dArr(K, 2) = Txt & sArr(I, 2)
        Else
            Rws = .Item(Tem)
            dArr(Rws, 2) = dArr(Rws, 2) & ", " & sArr(I, 2)
        End If
    Next I
End With
Range("E2:F1000").ClearContents
Range("E2:F2").Resize(K) = dArr
End Sub

 

[robinhsoon]

Xuất kết quả ra chỗ khác cho bạn kiểm tra nhé. Sau đó bạn muốn cho nó ở đâu thì tùy chỉnh lại.

Public Sub GPE_Ghep()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Tem As String, Txt As String, Rws As Long
sArr = Range("A2", Range("B2").End(xlDown)).Value
R = UBound(sArr): ReDim dArr(1 To R, 1 To 2)
Txt = "Tai sao ......... "
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        Tem = sArr(I, 1)
        If Not .Exists(Tem) Then
            K = K + 1: .Item(Tem) = K
            dArr(K, 1) = Tem: dArr(K, 2) = sArr(I, 2)
        Else
            Rws = .Item(Tem)
            If InStr(dArr(Rws, 2), Txt) = 0 Then dArr(Rws, 2) = Txt & dArr(Rws, 2)
            dArr(Rws, 2) = dArr(Rws, 2) & ", " & sArr(I, 2)
        End If
    Next I
End With
Range("E2:F1000").ClearContents
Range("E2:F2").Resize(K) = dArr
End Sub

Em làm được rồi ạ,
cảm ơn Thầy nhiều nhé, chúc thầy sức khỏe và thành công