Xin nhờ giúp đỡ: dò tìm dựa vào bảng mã nhóm khác

Liên hệ QC

hmgiang2009

Thành viên chính thức
Tham gia
16/7/11
Bài viết
74
Được thích
5
Dạ em xin chào các anh/chị ạ, xin anh/chị dành chút thời gian giúp đỡ em với ạ
em có bảng dữ liệu tại sheet 2023: trong đó có cột I, BI, EH. Tại sheet 1 em đã nhóm lại tất cả các mã (tại cột D) theo yêu cầu ở sheet 08, giờ em muốn tổng hợp lại dựa vào bảng dò đó, em xin anh chỉ giáo e với ạ
- Em xin đính kèm file, em xin cảm ơn rất nhiều
 

File đính kèm

  • do tim dua vao bang do ma nhom - Copy.xlsb
    5 MB · Đọc: 18
Dạ em xin chào các anh/chị ạ, xin anh/chị dành chút thời gian giúp đỡ em với ạ
em có bảng dữ liệu tại sheet 2023: trong đó có cột I, BI, EH. Tại sheet 1 em đã nhóm lại tất cả các mã (tại cột D) theo yêu cầu ở sheet 08, giờ em muốn tổng hợp lại dựa vào bảng dò đó, em xin anh chỉ giáo e với ạ
- Em xin đính kèm file, em xin cảm ơn rất nhiều
Tham khảo code sau:
Mã:
Option Explicit
Sub ABC()
Dim i&, j&, Lr&, t&, k&, Tong&
Dim Arr(), Data(), KQ(), SName(1 To 6)
Dim Dic As Object, Key
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("sheet1")
Lr = Sh.Cells(1000000, 1).End(xlUp).Row
Arr = Sh.Range("A2:D" & Lr).Value
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
    Key = Arr(i, 4)
        If Not Dic.Exists(Key) Then
            t = t + 1: Dic.Add (Key), t: Dic(Key) = Arr(i, 1)
        Else
            Dic(Key) = Dic(Key) & "," & Arr(i, 1)
        End If
Next i

Set Ws = Sheets("2023")
Lr = Ws.Cells(1000000, 9).End(xlUp).Row
Data = Ws.Range("I6:EH" & Lr).Value
ReDim KQ(1 To Dic.count, 1 To 2)
For i = 1 To UBound(Data)
    If Data(i, 130) <> Empty Then
        For Each Key In Dic.keys
            k = --Key
            If InStr(1, Dic(Key), Data(i, 130)) Then
                SName(k) = SName(k) + 1
                KQ(k, 1) = SName(k)
                KQ(k, 2) = KQ(k, 2) + Data(i, 53)
            End If
        Next Key
    End If
Next i
With Sheets("08")
    .Range("C3").Resize(6, 2).ClearContents
    .Range("C3").Resize(6, 2) = KQ
End With
Set Dic = Nothing
MsgBox "Done"
End Sub
Nhấn nút Run code trong file đính kèm để xem kết quả.
Lưu ý lần sau không nên viết tắt.
 

File đính kèm

  • do tim dua vao bang do ma nhom - Copy.xlsb
    5 MB · Đọc: 14
Đang nghi ngờ kết quả của Query thì vớ được code này để kiểm tra...
Dic quả lợi hại...
 

File đính kèm

  • 1111.png
    1111.png
    13.2 KB · Đọc: 21
Web KT
Back
Top Bottom