Giúp sửa code: Dùng Find Method để lấy dữ liệu ở nhiều Sheet khác nhau theo ĐK! (1 người xem)

[Hong.Van]

Em chào thầy cô & anh chị
Em có viết code Dùng Find Method để lấy dữ liệu ở nhiều Sheet khác nhau theo điều kiện như sau
1/ Code sẽ cho kết quả từ cell Q9 trở xuống của Sheet TH
2/ Tại sheet TH : Nếu cell của cột P>0, thì dùng cell cột C để dò tìm tên các sheet tương ứng là T01 .... T12
Sau đó dùng tiếp cell tại cột K của Sheet TH để dò tìm mã tại cột B của sheet T?? mà vừa tìm được ở trên, nếu tìm được thì sẽ lấy số liệu tại cột J của dòng tưng ứng
3/ Kết qủa của cột Q = Số liệu vừa tìm được ở trên nhân với cell của cột P tại dòng tương ứng của Sheet TH
Cụ thể cthức tại Cell Q9 của sheet TH như sau

=IF(P9>0;P9*VLOOKUP(K9;INDIRECT("'"&C9&"'!$B$9:$J$500");9;0);0)

-----------
Em đã viết code nhưng báo lỗi ở chỗ (dòng màu đỏ) , dòng xác định tên Sheet

Sub TTXuat()
    Dim i As Long
    Dim arrRes, arrSrc
    Dim n1 As Range, rTmp As Range
    Dim oldShName As Worksheet
    With ActiveSheet
        arrSrc = .Range(.[C9], .[C65536].End(3)).Resize(, 15).Value
    End With


    [COLOR=#ff0000]Set oldShName = Sheets(arrSrc(i, 1))[/COLOR]
    
    With oldShName
        Set n1 = .Range(.[B11], .[B65536].End(3))
    End With


    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 1)
    For i = 1 To UBound(arrSrc, 1)
        Set rTmp = n1.Find(arrSrc(i, 9), , xlValues, xlWhole)
        If Not rTmp Is Nothing Then


            If arrSrc(i, 14) > 0 Then arrRes(i, 1) = rTmp.Offset(, 9) * arrSrc(i, 14)
        End If


    Next i
    ActiveSheet.Range("Q9").Resize(UBound(arrRes, 1)).Value = arrRes
End Sub

Xin vui lòng gỡ rối và chỉ thêm cho em.Em cảm ơn

 

[Quang_Hải]

Set oldShName = Sheets(arrSrc(i, 1))

Em cảm ơn

Không cần xem file cũng biết lỗi. Lúc này i =0 đương nhiên là lỗi rồi

 

[ndu96081631]

Xin vui lòng gỡ rối và chỉ thêm cho em.Em cảm ơn

Đoạn màu đỏ ấy phải trong vòng lập chứ, nếu ở ngoài vòng lập thì biến i ở đâu ra để thế vào?
Ngoài ra đoạn này:

If arrSrc(i, 14) > 0 Then arrRes(i, 1) = rTmp.[COLOR=#ff0000][B]Offset(, 9)[/B][/COLOR] * arrSrc(i, 14)

Tôi nghĩ là Offset(, 8) mới đúng
Code sửa lại

Sub TTXuat()
  Dim i As Long
  Dim arrRes, arrSrc
  Dim n1 As Range, rTmp As Range
  Dim oldShName As Worksheet
  On Error Resume Next
  With Sheets("TH")
    arrSrc = .Range(.[C9], .[C65536].End(3)).Resize(, 15).Value
    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 1)
    For i = 1 To UBound(arrSrc, 1)
      Set oldShName = Sheets(arrSrc(i, 1))
      Set n1 = oldShName.Range("B9:B1000")
      Set rTmp = n1.Find(arrSrc(i, 9), , xlValues, xlWhole)
      If Not rTmp Is Nothing Then
        If arrSrc(i, 14) > 0 Then arrRes(i, 1) = rTmp.Offset(, 8) * arrSrc(i, 14)
      End If
    Next i
    .Range("Q9").Resize(UBound(arrRes, 1)).Value = arrRes
  End With
End Sub

 

[Quang_Hải]

Hãy cảm nhận sự khác nhau về tốc độ

Sub Xuat()
Dim Sarr(), DesArr(), i As Long, found As Range
With Sheets("TH")
   Sarr = .Range(.[C9], .[C65536].End(3)).Resize(, 15).Value
   ReDim DesArr(1 To UBound(Sarr), 1 To 1)
   For i = 1 To UBound(Sarr)
      If Sarr(i, 14) > 0 Then
         Set found = Sheets(Sarr(i, 1)).[B11:B10000].Find(Sarr(i, 9), , , xlWhole)
         If Not found Is Nothing Then
            DesArr(i, 1) = found.Offset(, 8) * Sarr(i, 14)
         End If
      End If
   Next
   .[T9].Resize(i - 1) = DesArr
End With
End Sub

Sub Xuat2()
Dim DesArr(), sh As Worksheet, TempArr()
Dim Sarr(), j As Long, i As Long
With Sheets("TH")
   Sarr = .Range(.[C9], .[C65536].End(3)).Resize(, 15).Value
   ReDim DesArr(1 To UBound(Sarr), 1 To 1)
   For Each sh In Worksheets
      If sh.Name <> "TH" Then
         TempArr = sh.Range(sh.[B11], sh.[B65536].End(3)).Resize(, 9).Value
         For i = 1 To UBound(Sarr)
            If Sarr(i, 1) = sh.Name Then
               If Sarr(i, 14) > 0 Then
                  For j = 1 To UBound(TempArr)
                    If Sarr(i, 9) = TempArr(j, 1) Then
                        DesArr(i, 1) = Sarr(i, 14) * TempArr(j, 9)
                        Exit For
                    End If
                  Next
               End If
            End If
         Next
      End If
   Next
   .[T9].Resize(i - 1) = DesArr
End With
End Sub

 

[TrungChinhs]

Bạn thử code này xem (không bàn về tốc độ nha)

Sub TongHop()
    Application.ScreenUpdating = False
    On Error Resume Next
    With Sheets("TH")
        For Each cls In Range(.[p9], .[p65536].End(3)).SpecialCells(2)
            sh = cls(1, -12)
            cls(1, 2) = Sheets(sh).Cells.Find(cls(1, -4))(1, 9) * cls
        Next
    End With
End Sub