Dò tim dữ liệu tất cả các sheet (1 người xem)

[lhthai]

Hiện tại đang dùng công thức lấy dữ liệu của sheet1 qua sheet KH
Nay muốn đổi thành code để áp dụng tất cả các sheet còn lại
Các anh xem file dinh kèm.

 

[ChanhTQ@]

Bạn hãy bấm vô biểu tượng mà bạn đã tạo ra để có kết quả mới & chúc vui!

 

[lhthai]

Cám ơn bạn nhiều
Code này nếu dữ liệu nhiều rất chạy chậm
Mình học hỏi code của anh Ba Tê nhưng chỉ dò được 1 mã hàng nay muốn sữa thành nhiều mà hàng
Bạn xem đoạn code sau sửa giúp mình được không

Private Sub CommandButton21_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([A4], [A4].End(xlDown)).Value
[COLOR=#ff0000]DK = [B3].Value[/COLOR]
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" Then
        CoL = Ws.[D4].End(xlToRight).Column - 1
        sArr = Ws.Range(Ws.[B4], Ws.[B65536].End(xlUp)).Resize(, CoL).Value
        For I = 7 To UBound(sArr, 1)
            If [COLOR=#ff0000]sArr(I, 1) = DK [/COLOR]Then
                For J = 3 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
[B4:B50000].ClearContents
[B4].Resize(UBound(dArr, 1)) = dArr
Set Dic = Nothing
End Sub

 

[Ba Tê]

Cám ơn bạn nhiều
Code này nếu dữ liệu nhiều rất chạy chậm
Mình học hỏi code của anh Ba Tê nhưng chỉ dò được 1 mã hàng nay muốn sữa thành nhiều mà hàng
Bạn xem đoạn code sau sửa giúp mình được không

Private Sub CommandButton21_Click()
.............
End Sub

Thử chạy code này coi sao

Public Sub GPE()
Dim Rws As Object, Col As Object, sArr(), dArr(), tArr(), I As Long, J As Long, C As Long
Dim nRws As Long, nCol As Long, Ws As Worksheet, iRws As Long, jCol As Long
Set Rws = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
sArr = Range([A4], [A4].End(xlDown)).Value
tArr = Range([B3], [B3].End(xlToRight)).Value
iRws = UBound(sArr, 1)
jCol = UBound(tArr, 2)
ReDim dArr(1 To iRws, 1 To jCol)
For I = 1 To iRws
    If Not Rws.Exists(sArr(I, 1)) Then Rws.Add sArr(I, 1), I
Next I
For J = 1 To jCol
    If Not Col.Exists(tArr(1, J)) Then Col.Add tArr(1, J), J
Next J
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "TH" Then
        With Ws
            C = .[D4].End(xlToRight).Column - 1
            sArr = .Range(.[B4], .[B65536].End(xlUp)).Resize(, C).Value
            For I = 7 To UBound(sArr, 1)
                For J = 3 To C
                    If Rws.Exists(sArr(1, J)) Then
                        If Col.Exists(sArr(I, 1)) Then
                            nRws = Rws.Item(sArr(1, J))
                            nCol = Col.Item(sArr(I, 1))
                            dArr(nRws, nCol) = dArr(nRws, nCol) + sArr(I, J)
                        End If
                    End If
                Next J
            Next I
        End With
    End If
Next Ws
Sheets("KH").[B4].Resize(iRws, jCol) = dArr
Set Rws = Nothing
Set Col = Nothing
End Sub

 

[lhthai]

Thử chạy code này coi sao

Public Sub GPE()
Dim Rws As Object, Col As Object, sArr(), dArr(), tArr(), I As Long, J As Long, C As Long
Dim nRws As Long, nCol As Long, Ws As Worksheet, iRws As Long, jCol As Long
Set Rws = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
sArr = Range([A4], [A4].End(xlDown)).Value
tArr = Range([B3], [B3].End(xlToRight)).Value
iRws = UBound(sArr, 1)
jCol = UBound(tArr, 2)
ReDim dArr(1 To iRws, 1 To jCol)
For I = 1 To iRws
    If Not Rws.Exists(sArr(I, 1)) Then Rws.Add sArr(I, 1), I
Next I
For J = 1 To jCol
    If Not Col.Exists(tArr(1, J)) Then Col.Add tArr(1, J), J
Next J
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "TH" Then
        With Ws
            C = Ws.[D4].End(xlToRight).Column - 1
            sArr = Range(.[B4], .[B65536].End(xlUp)).Resize(, C).Value
            For I = 7 To UBound(sArr, 1)
                For J = 3 To C
                    If Rws.Exists(sArr(1, J)) Then
                        If Col.Exists(sArr(I, 1)) Then
                            nRws = Rws.Item(sArr(1, J))
                            nCol = Col.Item(sArr(I, 1))
                            dArr(nRws, nCol) = dArr(nRws, nCol) + sArr(I, J)
                        End If
                    End If
                Next J
            Next I
        End With
    End If
Next Ws
Sheets("KH").[B4].Resize(iRws, jCol) = dArr
Set Rws = Nothing
Set Col = Nothing
End Sub

Em sữa đoạn này
sArr = Range(.[B4], .[B65536].End(xlUp)).Resize(, C).Value
Thành
sArr = Ws.Range(Ws.[B4], Ws.[B65536].End(xlUp)).Resize(, C).Value
Chạy được rồi
Cám ơn anh nhiều.