Nhờ viết code nối 2 sheet theo nhiều điều kiện có sẵn (không tính các ô trống) (1 người xem)

[littlecat1987]

- Sheet CT: sheet chứa danh sách chương trình - Ma dai dien, group, pk1,pk2,pk3,pk4,pk5
- Sheet SP: sheet chứa danh sách sản phẩm: mã model, group, pk1,pk2,pk3,pk4,pk5
- Mục đích: Nối hai sheet theo điều kiện trong Sheet CT: Group, PK1, PK2,PK3,PK4,PK5
Loại bỏ những ô trống và chỉ kiểm tra điều kiện trong những ô không trống

sheet KET QUA tạo ra một tổ hợp mới vì:
- Một chương trình có thể có nhiều sản phẩm
- Một sản phẩm có thể có nhiều chương trình
- Điều kiện để tạo ra tổ hợp là danh sách trong sheet CT

 

[Ba Tê]

- Sheet CT: sheet chứa danh sách chương trình - Ma dai dien, group, pk1,pk2,pk3,pk4,pk5
- Sheet SP: sheet chứa danh sách sản phẩm: mã model, group, pk1,pk2,pk3,pk4,pk5
- Mục đích: Nối hai sheet theo điều kiện trong Sheet CT: Group, PK1, PK2,PK3,PK4,PK5
Loại bỏ những ô trống và chỉ kiểm tra điều kiện trong những ô không trống

Bạn Xem thử file này, nếu đúng kết quả thì muốn sao nữa mình làm tiếp.

 

[quanluu]

- Sheet CT: sheet chứa danh sách chương trình - Ma dai dien, group, pk1,pk2,pk3,pk4,pk5
- Sheet SP: sheet chứa danh sách sản phẩm: mã model, group, pk1,pk2,pk3,pk4,pk5
- Mục đích: Nối hai sheet theo điều kiện trong Sheet CT: Group, PK1, PK2,PK3,PK4,PK5
Loại bỏ những ô trống và chỉ kiểm tra điều kiện trong những ô không trống

Nếu group ở sheet CT ko trống (trừ F106 trống hết) thì bạn chạy thử với code này tại sheet Ketqua

Sub tonghop()
Dim query As String
    query = "select b.f1, a.f1 from [SP$A2:G125] as b inner join [CT$A2:G40] as a on a.f2 = b.f2 and (a.f3 is null or a.f3 = b.f3) " & _
            "and (a.f4 is null or a.f4 = b.f4) and (a.f5 is null or a.f5 = b.f5) and (a.f6 is null or a.f6 = b.f6) and (a.f7 is null or a.f7 = b.f7)"
    Set cn = CreateObject("ADODB.Connection")
    cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1"";")
    Range("A2").CopyFromRecordset cn.Execute(query)
End Sub

 

[littlecat1987]

Cám ơn bạn, nhưng bạn có thể cho kết quả sang sheet KET QUA dùm mình không? sheet KET QUA tạo ra một tổ hợp mới vì:
- Một chương trình có thể có nhiều sản phẩm
- Một sản phẩm có thể có nhiều chương trình
- Điều kiện để tạo ra tổ hợp là danh sách trong sheet CT

 

[Ba Tê]

Cám ơn bạn, nhưng bạn có thể cho kết quả sang sheet KET QUA dùm mình không? sheet KET QUA tạo ra một tổ hợp mới vì:
- Một chương trình có thể có nhiều sản phẩm
- Một sản phẩm có thể có nhiều chương trình
- Điều kiện để tạo ra tổ hợp là danh sách trong sheet CT

Chẳng biết muốn "nói chuyện" với ai.

 

[HieuCD]

- Sheet CT: sheet chứa danh sách chương trình - Ma dai dien, group, pk1,pk2,pk3,pk4,pk5
- Sheet SP: sheet chứa danh sách sản phẩm: mã model, group, pk1,pk2,pk3,pk4,pk5
- Mục đích: Nối hai sheet theo điều kiện trong Sheet CT: Group, PK1, PK2,PK3,PK4,PK5
Loại bỏ những ô trống và chỉ kiểm tra điều kiện trong những ô không trống

sheet KET QUA tạo ra một tổ hợp mới vì:
- Một chương trình có thể có nhiều sản phẩm
- Một sản phẩm có thể có nhiều chương trình
- Điều kiện để tạo ra tổ hợp là danh sách trong sheet CT

bạn dùng code nầy thử

Sub GPE()
Dim Carr, Sarr, arr(1 To 2000, 1 To 2), d As Object
Dim i As Long, k As Long, n As Long, j As Integer
Carr = Sheets("CT").Range("A2:G40")
Sarr = Sheets("SP").Range("A2:H125")
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Carr)
    If Carr(i, 2) <> "" Then
        tmp = Carr(i, 2)
        For j = 3 To 7
            tmp = tmp & " " & IIf(Carr(i, j) = "", "*", Carr(i, j))
        Next j
        For n = 1 To UBound(Sarr)
            If i = 1 Then
                Sarr(n, 8) = Sarr(n, 2)
                For j = 3 To 7
                    Sarr(n, 8) = Sarr(n, 8) & " " & Sarr(n, j)
                Next j
            End If
            If Sarr(n, 8) Like tmp Then
                If Not d.exists(Sarr(n, 1) & " " & Carr(i, 1)) Then
                    d.Add Sarr(n, 1) & " " & Carr(i, 1), ""
                    k = k + 1
                    arr(k, 1) = Sarr(n, 1)
                    arr(k, 2) = Carr(i, 1)
                End If
            End If
        Next n
    End If
Next i
Sheets("KET QUA").Range("A2:B2000").ClearContents
Sheets("KET QUA").Range("A2").Resize(k, 2) = arr
Set d = Nothing
End Sub