Code dò tìm kết quả tất cả sheet (1 người xem)

[lhthai]

Chào các Anh
Em học hỏi từ code của anh quanghai áp dụng cho chương trình của em
Hiện tại code chỉ dò tìm được có 1 sheet nay muốn dò tìm tất cả các sheet khi thay đổi mã số.
Code hiện tại

Private Sub CommandButton1_Click()
On Error Resume Next
Dim Arr(), i&, j&, c&, rng As Range
[F8:IO5000].ClearContents
Arr = Sheet7.Range("B2", [B65536].End(3)).Resize(, 250).Value
For i = 7 To UBound(Arr)
   Set rng = Sheet5.[B:B].Find(Arr(i, 1), , , 1)
   If Not rng Is Nothing Then
      For j = 5 To UBound(Arr, 2)
         c = Sheet5.Rows(3).Find(Arr(2, j), , , 1).Column - 2
         Arr(i, j) = rng.Offset(, c) * Arr(i, 3)
      Next
   End If
Next
Sheet7.[B2].Resize(i - 6, 250) = Arr
End Sub

Code em chỉnh sữa áp dụng cho tất cả sheet nhưng không chạy

[TABLE="width: 623"]
[TR]
[TD]Private Sub CommandButton1_Click()[/TD]
[/TR]
[TR]
[TD]On Error Resume Next[/TD]
[/TR]
[TR]
[TD]Dim Arr(), i&, j&, c&, rng As Range, Ws As Worksheet[/TD]
[/TR]
[TR]
[TD]For Each Ws In ThisWorkbook.Worksheets[/TD]
[/TR]
[TR]
[TD]    If Ws.Name <> "KQ" Then[/TD]
[/TR]
[TR]
[TD][F8:IO5000].ClearContents[/TD]
[/TR]
[TR]
[TD]Arr = Ws.Range("B2", Ws.[B65536].End(3)).Resize(, 250).Value[/TD]
[/TR]
[TR]
[TD]For i = 7 To UBound(Arr)[/TD]
[/TR]
[TR]
[TD]   Set rng = Ws.[B:B].Find(Arr(i, 1), , , 1)[/TD]
[/TR]
[TR]
[TD]   If Not rng Is Nothing Then[/TD]
[/TR]
[TR]
[TD]      For j = 5 To UBound(Arr, 2)[/TD]
[/TR]
[TR]
[TD]         c = Ws.Rows(3).Find(Arr(2, j), , , 1).Column - 2[/TD]
[/TR]
[TR]
[TD]         Arr(i, j) = rng.Offset(, c) * Arr(i, 3)[/TD]
[/TR]
[TR]
[TD]      Next[/TD]
[/TR]
[TR]
[TD]   End If[/TD]
[/TR]
[TR]
[TD]Next[/TD]
[/TR]
[TR]
[TD]Sheet7.[B2].Resize(i - 6, 250) = Arr[/TD]
[/TR]
[TR]
[TD]End If[/TD]
[/TR]
[TR]
[TD]Next[/TD]
[/TR]
[/TABLE]

 

[Quang_Hải]

Code chắc chắn là chạy, nhưng có thể ra kết quả không như ý muốn.
Vì cái dòng đầu tiên nó giúp cho code chạy mượt mà rồi.

 

[lhthai]

Code chắc chắn là chạy, nhưng có thể ra kết quả không như ý muốn.
Vì cái dòng đầu tiên nó giúp cho code chạy mượt mà rồi.

Code chạy nhưng kết quả không đúng, anh có thể chỉ cho em cách sửa được không.
Cám ơn anh nhiều.

 

[Quang_Hải]

Code chạy nhưng kết quả không đúng, anh có thể chỉ cho em cách sửa được không.
Cám ơn anh nhiều.

Không ai có thể biết được thế nào là đúng, chỉ mình bạn biết thôi.

 

[lhthai]

Không ai có thể biết được thế nào là đúng, chỉ mình bạn biết thôi.

Nút lệnh của em hiện tại chỉ dò tìm được 1 sheet(01) nay em muốn dò tìm thêm sheet(02) nữa.
Ý em muốn nút lệnh dò tìm kết quả trong sheet(01) không có thì dò tìm tiếp sheet(02) khi thay đổi phần mã số.

 

[Ba Tê]

Nút lệnh của em hiện tại chỉ dò tìm được 1 sheet(01) nay em muốn dò tìm thêm sheet(02) nữa.
Ý em muốn nút lệnh dò tìm kết quả trong sheet(01) không có thì dò tìm tiếp sheet(02) khi thay đổi phần mã số.

Trường hợp này thì: Dò 1 sheet khác, dò nhiều sheet khác. Khó mà sửa code.
Xài tạm cái mớ bòng bong này xem sao.
Nhìn dữ liệu chóng mặt luôn, không kiểm tra kết quả được.

Public Sub BongBongBong()
Application.ScreenUpdating = False
Dim Col As Object, Dic As Object, sArr(), dArr(), tArr(), I As Long, J As Long, K As Long
Dim Tem As String, Ws As Worksheet, R As Long, C As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
With Sheets("KQ")
    C = .[F2].End(xlToRight).Column - 5
    sArr = .[F2].Resize(, C).Value
    tArr = .Range(.[B8], .[B65536].End(xlDown)).Resize(, 3).Value
    R = UBound(tArr, 1)
End With
ReDim dArr(1 To R, 1 To C)
For J = 1 To C
    If Not Col.Exists(sArr(1, J)) Then Col.Add sArr(1, J), J
Next J
For I = 1 To R
    If Not Dic.Exists(tArr(I, 1)) Then Dic.Add tArr(I, 1), I
Next I
For Each Ws In Worksheets
    If Ws.Name <> "KQ" Then
        sArr = Ws.Range(Ws.[B2], Ws.[B65536].End(xlUp)).Resize(, Ws.[I2].End(xlToRight).Column).Value
        For I = 7 To UBound(sArr, 1)
            Tem = sArr(I, 1)
            If Dic.Exists(sArr(I, 1)) Then
                For J = 8 To UBound(sArr, 2)
                    If sArr(I, J) <> Empty Then
                        If Col.Exists(sArr(1, J)) Then
                            dArr(Dic.Item(Tem), Col.Item(sArr(1, J))) = sArr(I, J) * tArr(Dic.Item(Tem), 3)
                        End If
                    End If
                Next J
            End If
        Next I
    End If
Next Ws
Sheets("KQ").[F8].Resize(R, C) = dArr
Set Dic = Nothing
Set Col = Nothing
End Sub

 

[lhthai]

Trường hợp này thì: Dò 1 sheet khác, dò nhiều sheet khác. Khó mà sửa code.
Xài tạm cái mớ bòng bong này xem sao.
Nhìn dữ liệu chóng mặt luôn, không kiểm tra kết quả được.

Public Sub BongBongBong()
Application.ScreenUpdating = False
Dim Col As Object, Dic As Object, sArr(), dArr(), tArr(), I As Long, J As Long, K As Long
Dim Tem As String, Ws As Worksheet, R As Long, C As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Col = CreateObject("Scripting.Dictionary")
With Sheets("KQ")
    C = .[F2].End(xlToRight).Column - 5
    sArr = .[F2].Resize(, C).Value
    tArr = .Range(.[B8], .[B65536].End(xlDown)).Resize(, 3).Value
    R = UBound(tArr, 1)
End With
ReDim dArr(1 To R, 1 To C)
For J = 1 To C
    If Not Col.Exists(sArr(1, J)) Then Col.Add sArr(1, J), J
Next J
For I = 1 To R
    If Not Dic.Exists(tArr(I, 1)) Then Dic.Add tArr(I, 1), I
Next I
For Each Ws In Worksheets
    If Ws.Name <> "KQ" Then
        sArr = Ws.Range(Ws.[B2], Ws.[B65536].End(xlUp)).Resize(, Ws.[I2].End(xlToRight).Column).Value
        For I = 7 To UBound(sArr, 1)
            Tem = sArr(I, 1)
            If Dic.Exists(sArr(I, 1)) Then
                For J = 8 To UBound(sArr, 2)
                    If sArr(I, J) <> Empty Then
                        If Col.Exists(sArr(1, J)) Then
                            dArr(Dic.Item(Tem), Col.Item(sArr(1, J))) = sArr(I, J) * tArr(Dic.Item(Tem), 3)
                        End If
                    End If
                Next J
            End If
        Next I
    End If
Next Ws
Sheets("KQ").[F8].Resize(R, C) = dArr
Set Dic = Nothing
Set Col = Nothing
End Sub

Em test kết quả Ok rồi anh.
Code của anh Quanghai và Anh Ba Tê điều rất hay.
Code của anh quanghai dò tìm 1 sheet cột B và dòng 3 trùng nhau điều tính được cả(tương tự hàm Index)
Còn code Anh Ba Tê thì ngược lại cột B và dòng 3 không được trùng nhau.
Cám ơn các Anh rất nhiều.