Lộc dữ liệu tất cả các sheet (1 người xem)

[lhthai]

Hiện tại nút "Run" chỉ lộc được 1 mã số
Mình bổ sung thêm mã số sau cột T5
Nhờ các anh điều chỉnh
Lộc dự liệu tất cả các mã hàng tương tự như hàm Index nhưng cái này áp dụng nhiều sheet

Private Sub CommandButton3_Click()
Dim sArr(), dArr(), I As Long, J As Long, DK As String, Dic As Object, Tem As String, CoL As Long, Ws As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range([P6], [P6].End(xlDown)).Value
DK = [T5].Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    If Not Dic.Exists(Tem) Then Dic.Add Tem, I
Next I
For Each Ws In Worksheets
   If Ws.Name <> "KH" And Ws.Name <> "CELL" Then
        CoL = Ws.[J4].End(xlToRight).Column - 1
        sArr = Ws.Range(Ws.[B4], Ws.[B65536].End(xlUp)).Resize(, CoL).Value
        For I = 7 To UBound(sArr, 1)
            If sArr(I, 1) = DK Then
                For J = 9 To UBound(sArr, 2)
                    Tem = sArr(1, J)
                    If Dic.Exists(Tem) Then dArr(Dic.Item(Tem), 1) = sArr(I, J)
                Next J
            End If
        Next I
    End If
Next Ws
[T6:T50000].ClearContents
[T6].Resize(UBound(dArr, 1)) = dArr
Set Dic = Nothing
End Sub

 

[lhthai]

Anh nào hướng dẫn dùm

 

[lhthai]

Hiện tại nút "Run" chỉ lộc được 1 mã số
Mình bổ sung thêm mã số sau cột T5
Nhờ các anh điều chỉnh

Private Sub CommandButton3_Click()
Dim sArr(), dArr(), I As Long, J As Long, DK As String, Dic As Object, Tem As String, CoL As Long, Ws As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range([P6], [P6].End(xlDown)).Value
DK = [T5].Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 1)
    If Not Dic.Exists(Tem) Then Dic.Add Tem, I
Next I
For Each Ws In Worksheets
   If Ws.Name <> "KH" And Ws.Name <> "CELL" Then
        CoL = Ws.[J4].End(xlToRight).Column - 1
        sArr = Ws.Range(Ws.[B4], Ws.[B65536].End(xlUp)).Resize(, CoL).Value
        For I = 7 To UBound(sArr, 1)
            If sArr(I, 1) = DK Then
                For J = 9 To UBound(sArr, 2)
                    Tem = sArr(1, J)
                    If Dic.Exists(Tem) Then dArr(Dic.Item(Tem), 1) = sArr(I, J)
                Next J
            End If
        Next I
    End If
Next Ws
[T6:T50000].ClearContents
[T6].Resize(UBound(dArr, 1)) = dArr
Set Dic = Nothing
End Sub

Code này lúc trước anh Ba Tê viết nay muốn bổ sung thêm nhờ anh viết giúp.