Tìm Theo Tên Khách Hàng và Loại Cung Cấp (1 người xem)

[tam8678]

Rất mong các anh em trên GPE xem và giúp dùm code cho việc tìm kiếm theo đúng tên khách hàng và đúng loại cung cấp. Yêu cầu cụ thể được ghi trong file đính kèm. Cám ơn

 

[Quang_Hải]

Trong khi chờ đợi giải pháp ngắn gọn hơn thì xài tạm cách chữa cháy này nhé

 

[concogia]

Rất mong các anh em trên GPE xem và giúp dùm code cho việc tìm kiếm theo đúng tên khách hàng và đúng loại cung cấp. Yêu cầu cụ thể được ghi trong file đính kèm. Cám ơn

Hình như anh muốn kết quả nhập trực tiếp vào vùng chứa các cột A, B, C thì phải
Nếu đúng thế anh chạy thử code này xem:

Public Sub Loc()
    Dim VungA, VungB, d, I, Gom, K, kK
    VungA = Range([A2], [A10000].End(xlUp)).Resize(, 3)
    VungB = Range([G2], [G10000].End(xlUp)).Resize(, 3)
    Set d = CreateObject("scripting.dictionary")
        For I = 1 To UBound(VungA)
            If Not d.exists(VungA(I, 1) & VungA(I, 2)) Then
                K = K + 1
                d.Add VungA(I, 1) & VungA(I, 2), K
            End If
        Next I
            For I = 1 To UBound(VungB)
                Gom = VungB(I, 1) & VungB(I, 2)
                    If Not d.exists(Gom) Then
                        K = K + 1
                        d.Add Gom, K
                            With [A500].End(xlUp)(2)
                                .Value = VungB(I, 1)
                                .Offset(, 1).Value = VungB(I, 2)
                                .Offset(, 2).Value = VungB(I, 3)
                            End With
                    Else
                            kK = d.Item(Gom)
                            Cells(kK + 1, 3) = Cells(kK + 1, 3) + VungB(I, 3)
                    End If
            Next I
End Sub

Thân

 

[tam8678]

Hình như anh muốn kết quả nhập trực tiếp vào vùng chứa các cột A, B, C thì phải
Nếu đúng thế anh chạy thử code này xem:

Public Sub Loc()
    Dim VungA, VungB, d, I, Gom, K, kK
    VungA = Range([A2], [A10000].End(xlUp)).Resize(, 3)
    VungB = Range([G2], [G10000].End(xlUp)).Resize(, 3)
    Set d = CreateObject("scripting.dictionary")
        For I = 1 To UBound(VungA)
            If Not d.exists(VungA(I, 1) & VungA(I, 2)) Then
                K = K + 1
                d.Add VungA(I, 1) & VungA(I, 2), K
            End If
        Next I
            For I = 1 To UBound(VungB)
                Gom = VungB(I, 1) & VungB(I, 2)
                    If Not d.exists(Gom) Then
                        K = K + 1
                        d.Add Gom, K
                            With [A500].End(xlUp)(2)
                                .Value = VungB(I, 1)
                                .Offset(, 1).Value = VungB(I, 2)
                                .Offset(, 2).Value = VungB(I, 3)
                            End With
                    Else
                            kK = d.Item(Gom)
                            Cells(kK + 1, 3) = Cells(kK + 1, 3) + VungB(I, 3)
                    End If
            Next I
End Sub

Thân

---
Cám ơn anh Concogia thật nhiều, mong anh lấy hết công lực diển giải dùm trình tự hoạt động code . Mến

 

[concogia]

Thật ra code này là món Tả-Pín-Lù, lúc đầu định sử dụng hoàn toàn mảng nhưng nhìn lại thấy gán trực tiếp cho dễ hiểu & dễ kiểm tra hơn nên đổi lại
Public Sub Loc() Dim VungA, VungB, d, I, Gom, K, kK
* Khai báo các biến
VungA = Range([A2], [A10000].End(xlUp)).Resize(, 3)
VungB = Range([G2], [G10000].End(xlUp)).Resize(, 3)
* Gán các vùng dữ liệu cho các biến VungA & VungB
Set d = CreateObject("scripting.dictionary")
* Khai báo biến d là một em "Đít- to"
For I = 1 To UBound(VungA)
* Cho biến I chạy từ 1 đến số dòng của vùng dữ liệu VungA
If Not d.exists(VungA(I, 1) & VungA(I, 2)) Then
* Nếu trong em "Đít- to" chưa có dữ liệu VungA(I, 1) & VungA(I, 2) thì
K = K + 1
* Biến K tăng 1
d.Add VungA(I, 1) & VungA(I, 2), K
* Gán dữ liệu (VungA(I, 1) & VungA(I, 2) vào Key của em "Đít- to", Gán biến K vào Item của "Đít - to"
End If
Next I
* Thoát vòng lặp & hoàn thành tạo "Đít-to"
For I = 1 To UBound(VungB)
* Cho biến I chạy từ 1 đến số dòng của vùng dữ liệu VungB
Gom = VungB(I, 1) & VungB(I, 2)
* Gán dữ liệu cho biến Gom ( nhìn cho đỡ rối mắt thôi, chứ không có biến này cũng chẳng chết thằng tây nào)
If Not d.exists(Gom) Then
* Nếu trong "Đít-to" chưa có Gom thì
K = K + 1 d.Add Gom, K
* gán dữ liệu vào "Đít-to"
With [A500].End(xlUp)(2)
* Từ cell [A500] chạy ngược lên đầu bảng tính, đụng thằng nào có dữ liệu thì Xì- tốp, xong lùi ngược lại một hàng
.Value = VungB(I, 1)
.Offset(, 1).Value = VungB(I, 2)
.Offset(, 2).Value = VungB(I, 3) End With
* Gán dữ liệu có ở bảng B mà không có ở bảng A
Else
* Nếu có rồi thì
kK = d.Item(Gom)
* Tìm vị trí có rồi xuất hiện trong "Đí-to"
Cells(kK + 1, 3) = Cells(kK + 1, 3) + VungB(I, 3)
* Cộng số lượng ở cột thứ 3
End If
Next I
End Sub

 

[huuthang_bd]

Rất mong các anh em trên GPE xem và giúp dùm code cho việc tìm kiếm theo đúng tên khách hàng và đúng loại cung cấp. Yêu cầu cụ thể được ghi trong file đính kèm. Cám ơn

Chắc anh Tâm cần tốc độ hơn là dễ hiểu .
Mà Bác Cò chưa bẫy lỗi trường hợp vùng kết quả chưa có dữ liệu hoặc vùng kết quả có dữ liệu nhưng có những dòng dữ liệu 2 cột đầu giống nhau nhé.
Em mạng phép thay Bác Cò chuyển qua dùng mảng cho nhanh.

Dim KetQua, Dic, I As Long, j As Long, K As Long

Sub Gop()
Dim DaCo, ThemVao
Set Dic = CreateObject("Scripting.Dictionary")
DaCo = Range([C2], [A65536].End(xlUp).Offset(1)).Value
ThemVao = Range([I2], [G65536].End(xlUp).Offset(1)).Value
ReDim KetQua(1 To UBound(DaCo, 1) + UBound(ThemVao, 1), 1 To 3)
ThemDL DaCo
ThemDL ThemVao
[A2].Resize(j, 3).Value = KetQua
End Sub

Private Sub ThemDL(ByVal DL)
    For I = 1 To UBound(DL, 1) - 1
    If Dic.exists(DL(I, 1) & vbBack & DL(I, 2)) Then
        KetQua(Dic.Item(DL(I, 1) & vbBack & DL(I, 2)), 3) = KetQua(Dic.Item(DL(I, 1) & vbBack & DL(I, 2)), 3) + DL(I, 3)
    Else
        j = j + 1
        For K = 1 To 3
            KetQua(j, K) = DL(I, K)
        Next
        Dic.Add DL(I, 1) & vbBack & DL(I, 2), j
    End If
Next
End Sub

 

[concogia]

Chắc anh Tâm cần tốc độ hơn là dễ hiểu .
Mà Bác Cò chưa bẫy lỗi trường hợp vùng kết quả chưa có dữ liệu hoặc vùng kết quả có dữ liệu nhưng có những dòng dữ liệu 2 cột đầu giống nhau nhé.
Em mạng phép thay Bác Cò chuyển qua dùng mảng cho nhanh.

Dim KetQua, Dic, I As Long, j As Long, K As Long

Sub Gop()
Dim DaCo, ThemVao
Set Dic = CreateObject("Scripting.Dictionary")
DaCo = Range([C2], [A65536].End(xlUp).Offset(1)).Value
ThemVao = Range([I2], [G65536].End(xlUp).Offset(1)).Value
ReDim KetQua(1 To UBound(DaCo, 1) + UBound(ThemVao, 1), 1 To 3)
ThemDL DaCo
ThemDL ThemVao
[A2].Resize(j, 3).Value = KetQua
End Sub

Private Sub ThemDL(ByVal DL)
    For I = 1 To UBound(DL, 1) - 1
    If Dic.exists(DL(I, 1) & vbBack & DL(I, 2)) Then
        KetQua(Dic.Item(DL(I, 1) & vbBack & DL(I, 2)), 3) = KetQua(Dic.Item(DL(I, 1) & vbBack & DL(I, 2)), 3) + DL(I, 3)
    Else
        j = j + 1
        For K = 1 To 3
            KetQua(j, K) = DL(I, K)
        Next
        Dic.Add DL(I, 1) & vbBack & DL(I, 2), j
    End If
Next
End Sub

Theo mình, cái bảng A chắc chắn không có dữ liệu trùng ở 2 cột đầu
Còn nếu chưa có dữ liệu thì.......híc
Dạng bài này theo mình nghĩ là anh ấy cập nhật liên tục ( có thể sau một vài ngày hay sau một đợt hàng_ Híc, mình cũng cóc biết nữa Thắng ạ, làm đại thôi, hihi) ==> dữ liệu bảng A luôn luôn có & luôn luôn duy nhất
Hôm nào Óp một bữa chứ chú Thắng, cũng lâu rồi không gặp em
Thân