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

Chia sẻ bởi:hands

★★★★★

‹ Giúp viết code: Cộng dồn, trừ dồn... Giúp viết code dò tìm và nối... ›

Quảng cáo

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

Đ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

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-s%E1%BB%ADa-code-d%C3%B9ng-find-method-%C4%91%E1%BB%83-l%E1%BA%A5y-d%E1%BB%AF-li%E1%BB%87u-%E1%BB%9F-nhi%E1%BB%81u-sheet-kh%C3%A1c-nhau-theo-%C4%90k.75789/post-465366

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(., ..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))..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
..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(., ..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., sh..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
..Resize(i – 1) = DesArr
End With
End Sub

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

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-s%E1%BB%ADa-code-d%C3%B9ng-find-method-%C4%91%E1%BB%83-l%E1%BA%A5y-d%E1%BB%AF-li%E1%BB%87u-%E1%BB%9F-nhi%E1%BB%81u-sheet-kh%C3%A1c-nhau-theo-%C4%90k.75789/post-465393