Giúp đỡ - Dò tìm và tổng hợp (tổ hợp) dữ liệu

[Deleted member 1077]

Xin chào mọi người !

Em là người mới nên có gì trình bày còn sơ sót mong mọi người góp ý giúp em hoàn thiện hơn !

Để mọi người dễ hình dung, Em xin trình bày vấn đề của em bằng hình ảnh hóa như sau ạ:

Bạn cần đăng nhập để thấy hình ảnh

Mục đích: Dò và tổng hợp dữ liệu từ 2 Sheet khác nhau theo Logic (như hình)

Đầu vào: SHEET A và SHEET B với các dữ liệu như hình

Đầu ra: SHEET C với các dữ liệu chờ kết quả chạy code

Em xin đính kèm file của em tại

Bạn cần đăng nhập để thấy link

Nếu em có trình bày chổ nào khó hiểu, mong Anh/Chị góp ý giúp cho để em hoàn thiện hơn. Em xin cảm ơn Anh/Chị rất nhiều.

 

[Deleted member 208]

Bạn dùng code sau:

Sub tuhocvba()
    Dim i   As Long, j As Long
    Dim rend1   As Long, rend2  As Long, cnt As Long
    Dim arr     As Variant, brr As Variant, kqrr As Variant, temprr As Variant
    Dim keytemp As String
    Dim myDic As Object
    
    Const r1    As Long = 1 'Dong tieu de cua ca 3 sheet
    Const ip1   As String = "SHEET A"
    Const ip2   As String = "SHEET B"
    Const op    As String = "SHEET C"
    
    ThisWorkbook.Sheets(ip1).Activate
    
    'Lam viec voi SHEET A
    rend1 = ThisWorkbook.Sheets(ip1).Cells(Rows.Count, 1).End(xlUp).Row 'dong cuoi cot A cua sheet A
    If rend1 <= r1 Then
        MsgBox "Sheet: " & ip1 & " khong co du lieu"
        Exit Sub
    End If
    arr = ThisWorkbook.Sheets(ip1).Range(Cells(r1 + 1, 1), Cells(rend1, 2)).Value
    'Lam viec voi SHEET B
     ThisWorkbook.Sheets(ip2).Activate
    rend2 = ThisWorkbook.Sheets(ip2).Cells(Rows.Count, 1).End(xlUp).Row 'dong cuoi cot A cua sheet A
    If rend2 <= r1 Then
        MsgBox "Sheet: " & ip1 & " khong co du lieu"
        Exit Sub
    End If
    brr = ThisWorkbook.Sheets(ip2).Range(Cells(r1 + 1, 1), Cells(rend2, 3)).Value
    Set myDic = CreateObject("Scripting.Dictionary")
    
    'Lam viec voi du lieu cua SHEET A
    For i = LBound(arr, 1) To UBound(arr, 1) Step 1
        keytemp = CStr(arr(i, 1)) 'Ten san pham. Ex: A1
        If Not myDic.Exists(keytemp) Then
            myDic.Add keytemp, CStr(arr(i, 2)) 'Ten SP-Ma Quy Doi
        Else
            myDic.Item(keytemp) = myDic.Item(keytemp) & "_tuhocvba.net_" & CStr(arr(i, 2))
        End If
    Next i
    
    'Lam viec voi du lieu cua SHEET B
    cnt = 0
    ReDim kqrr(1 To 3, 1 To 1)
    For i = LBound(brr, 1) To UBound(brr, 1) Step 1
        keytemp = CStr(brr(i, 1))
        If myDic.Exists(keytemp) Then
            temprr = Split(myDic.Item(keytemp), "_tuhocvba.net_")
            
            For j = LBound(temprr) To UBound(temprr) Step 1
                cnt = cnt + 1
                ReDim Preserve kqrr(1 To 3, 1 To cnt)
                kqrr(1, cnt) = CStr(temprr(j))
                kqrr(3, cnt) = CStr(brr(i, 3)) 'Loai SP
                kqrr(2, cnt) = CStr(brr(i, 2)) 'Ma SP
            Next j

        End If
    Next i
    
    'Ghi ket qua ra SHEET C
    ThisWorkbook.Sheets(op).Activate
    ThisWorkbook.Sheets(op).Range(Cells(r1 + 1, 1), Cells(cnt + 1, 3)).Value = transposeArray(kqrr)
    Set myDic = Nothing
End Sub
Function transposeArray(myarr As Variant) As Variant
    Dim myvar As Variant
    Dim i As Long, j As Long
    ReDim myvar(LBound(myarr, 2) To UBound(myarr, 2), LBound(myarr, 1) To UBound(myarr, 1))
    For i = LBound(myarr, 2) To UBound(myarr, 2)
        For j = LBound(myarr, 1) To UBound(myarr, 1)
            myvar(i, j) = myarr(j, i)
        Next
    Next
    transposeArray = myvar
End Function

Kết quả:

Bạn cần đăng nhập để thấy hình ảnh

 

[tuhocvba]

Topic này thì tính tổ hợp toán nhiều hơn là dò tìm, cho nên cho mình đổi lại tên topic cho đúng bản chất vấn đề nhé.
Bài viết #1 trình bày là dễ hiểu.

Bạn cần đăng nhập để thấy hình ảnh

 

[Deleted member 1077]

@sieutocviet3 Vâng, Em đã dành thời gian chạy thử Code. Kết quả ra là chuẩn ạ. Em xin cảm ơn Anh rất nhiều vì đã dành thời gian Code giúp Em.
@tuhocvba Cảm ơn Anh đã góp ý, Anh cứ đổi tiêu đề cho đúng bản chất vấn đề ạ. Em cảm ơn Anh.

Do em không có điều kiện về kinh tế nên không ủng hộ diễn đàn mình được, nhưng em sẽ giới thiệu diễn đàn tuhocvba.net với các bạn của em xem như một hình thức ủng hộ ạ!

 

[Deleted member 208]

Không có gì, sau một thời gian đọc bài viết trên diễn đàn, lĩnh hội được chút ít kiến thức của các anh chị trong BQT, giúp được bạn là tôi vui rồi. Chỉ là giúp đỡ tí tẹo vì bạn trình bày yêu cầu cũng dễ hiểu nên không mất thời gian code lắm.

 

[NhanSu]

Cảm ơn admin đã mở lại chủ đề này. Theo mô tả thì đây là ví dụ điển hình của việc join 2 bảng, vì vậy mình xin post code sử dụng ADO để các bạn và chủ topic tham khảo thêm. Trong thực tế mình ít khi sử ụng ADO vì nghe nói các object chiếm dụng bộ nhớ kể cả sau khi đã được set = nothing. Các cột trong sheet A và B mình đã sửa, bỏ dấu tiếng Việt đi.

Sub JoinADO()
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim cntStr As String
    cntStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 8.0;HDR=YES"";"
    Set cnn = New ADODB.Connection
    cnn.Open cntStr
    Set rs = New ADODB.Recordset
    rs.Open "SELECT MaQuyDoi,Ma,Loai FROM ['SHEET A$'] a INNER JOIN ['SHEET B$'] b ON a.TenSP=b.TenSP ORDER BY MaQuyDoi,Ma,Loai", cnn
    Sheet6.Range("A2").CopyFromRecordset rs
    rs.Close
    Set rs = Nothing
    cnn.Close
    Set cnn = Nothing
End Sub

Bạn cần đăng nhập để thấy link