Code Vlookup bị chậm

Phương Phương mito · 2/3/21

Em có đoạn Code này nó chạy được. Nhưng nó chạy chậm do phải tìm theo từng ô. Có cách gì sửa để nó chạy tốt hơn không ạ. Em cảm ơn ạ.

Sub Timkiem ()

Dim i As Long, j&, lr&
lr = Sheet9.Cells(Rows.Count, 4).End(xlUp).Row
lr1 = Sheet10.Cells(Rows.Count, 1).End(xlUp).Row

With Sheet10
For j = 2 To lr
For i = 5 To lr1

If .Cells(i, 1) = Sheet9.Cells(j, 4) And .Cells(i, 1).Offset(, Sheet10.Range("A1").Value - 1) = "x" Then
Sheet9.Cells(j, 4).Offset(, 42) = "x"

ElseIf .Cells(i, 1) = Sheet9.Cells(j, 4) And .Cells(i, 1).Offset(, Sheet10.Range("A1").Value - 1) = "" Then
Sheet9.Cells(j, 4).Offset(, 42).ClearContents

End If
Next
Next

End With

End Sub

Nhattanktnn · 2/3/21

Phương Phương mito đã viết:
Em có đoạn Code này nó chạy được. Nhưng nó chạy chậm do phải tìm theo từng ô. Có cách gì sửa để nó chạy tốt hơn không ạ. Em cảm ơn ạ.

Sub Timkiem ()

Dim i As Long, j&, lr&
lr = Sheet9.Cells(Rows.Count, 4).End(xlUp).Row
lr1 = Sheet10.Cells(Rows.Count, 1).End(xlUp).Row

With Sheet10
For j = 2 To lr
For i = 5 To lr1

If .Cells(i, 1) = Sheet9.Cells(j, 4) And .Cells(i, 1).Offset(, Sheet10.Range("A1").Value - 1) = "x" Then
Sheet9.Cells(j, 4).Offset(, 42) = "x"

ElseIf .Cells(i, 1) = Sheet9.Cells(j, 4) And .Cells(i, 1).Offset(, Sheet10.Range("A1").Value - 1) = "" Then
Sheet9.Cells(j, 4).Offset(, 42).ClearContents

End If
Next
Next

End With

End Sub

Bài này nên xử lý trong mảng và đổ một lần ra sheet, không nên lặp từng ô trên bảng tính như vậy sẽ bị chậm

VetMini · 2/3/21

Code trên tính lủng củng bỏ bố. Hình như người viết code khoias cái hàm Offset, không dùng không chịu được.

Điển hình:
Sheet10.Cells(i, 1).Offset(, Sheet10.Range("A1").Value - 1)
Cái phần đỏ đỏ được tính (lr-1)*(lr2)*1.5 lần trong khi nó chỉ là một trị chỉ cần tính 1 lần.
triOffset = Sheet10.Range("A1").Value
...
If Sheet10.Cells(i, 1) = Sheet9.Cells(j, 4) And Sheet10.Cells(i,triOffset ) = "x" Then
Sheet9.Cells(j, 46) = "x"
ElseIf .Cells(i, 1) = Sheet9.Cells(j, 4) And .Cells(i, triOffset) = "" Then

Đặt tên biến cũng lủng củng. Nếu có hai vùng thì đặt hẳn lr1, lr2 và i1, i2 luôn cho dễ theo dõi.

HieuCD · 3/3/21

Phương Phương mito đã viết:
Em có đoạn Code này nó chạy được. Nhưng nó chạy chậm do phải tìm theo từng ô. Có cách gì sửa để nó chạy tốt hơn không ạ. Em cảm ơn ạ.

Sub Timkiem ()

Dim i As Long, j&, lr&
lr = Sheet9.Cells(Rows.Count, 4).End(xlUp).Row
lr1 = Sheet10.Cells(Rows.Count, 1).End(xlUp).Row

With Sheet10
For j = 2 To lr
For i = 5 To lr1

If .Cells(i, 1) = Sheet9.Cells(j, 4) And .Cells(i, 1).Offset(, Sheet10.Range("A1").Value - 1) = "x" Then
Sheet9.Cells(j, 4).Offset(, 42) = "x"

ElseIf .Cells(i, 1) = Sheet9.Cells(j, 4) And .Cells(i, 1).Offset(, Sheet10.Range("A1").Value - 1) = "" Then
Sheet9.Cells(j, 4).Offset(, 42).ClearContents

End If
Next
Next

End With

End Sub

Code chạy chậm do rất nhiều nguyên nhân, tinh chỉnh lại theo cách của bạn

Mã:

Sub Timkiem()
  Dim i&, i2&, c&, lr&, lr2&, tmp
  Const jC& = 46 'Cot ket qua
 
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  lr = Sheet9.Cells(Rows.Count, 4).End(xlUp).Row
  With Sheet10
    c = .Range("A1").Value
    lr2 = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lr
      tmp = Sheet9.Cells(i, 4)
      For i2 = 5 To lr2
        If .Cells(i2, 1) = tmp Then
          If .Cells(i2, c) = "x" Then
            Sheet9.Cells(i, jC) = "x"
          ElseIf .Cells(i2, c) = "" Then
            Sheet9.Cells(i, jC).ClearContents
          End If
          Exit For
        End If
      Next i2
    Next i
  End With
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Nếu muốn nhanh hơn nhiều, dùng Dictionary, kết quả theo dạng hàm Vlookup, có thể không giống code của bạn

Mã:

Sub ABC()
  Dim sArr(), sArr2(), Res(), Dic As Object, i&, sRow&
  Const jC& = 46 'Cot ket qua Sheet9
 
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Set Dic = CreateObject("scripting.dictionary")
  With Sheet10
    sArr = .Range("A5", .Range("A" & Rows.Count).End(xlUp)).Value
    sRow = UBound(sArr)
    sArr2 = .Range("A5").Offset(, .Range("A1").Value - 1).Resize(sRow).Value
  End With
  For i = 1 To sRow
    If Dic.exists(sArr(i, 1)) = False Then Dic.Add sArr(i, 1), sArr2(i, 1)
  Next i
 
  With Sheet9
    sArr = .Range("D2", .Range("D" & Rows.Count).End(xlUp)).Value
    sRow = UBound(sArr)
    ReDim Res(1 To sRow, 1 To 1)
    For i = 1 To sRow
      Res(i, 1) = Dic.Item(sArr(i, 1))
    Next i
    .Cells(2, jC).Resize(sRow) = Res
  End With
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Phương Phương mito · 3/3/21

HieuCD đã viết:

Code chạy chậm do rất nhiều nguyên nhân, tinh chỉnh lại theo cách của bạn

Mã:

Sub Timkiem()
  Dim i&, i2&, c&, lr&, lr2&, tmp
  Const jC& = 46 'Cot ket qua

  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  lr = Sheet9.Cells(Rows.Count, 4).End(xlUp).Row
  With Sheet10
    c = .Range("A1").Value
    lr2 = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lr
      tmp = Sheet9.Cells(i, 4)
      For i2 = 5 To lr2
        If .Cells(i2, 1) = tmp Then
          If .Cells(i2, c) = "x" Then
            Sheet9.Cells(i, jC) = "x"
          ElseIf .Cells(i2, c) = "" Then
            Sheet9.Cells(i, jC).ClearContents
          End If
          Exit For
        End If
      Next i2
    Next i
  End With
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Nếu muốn nhanh hơn nhiều, dùng Dictionary, kết quả theo dạng hàm Vlookup, có thể không giống code của bạn

Mã:

Sub ABC()
  Dim sArr(), sArr2(), Res(), Dic As Object, i&, sRow&
  Const jC& = 46 'Cot ket qua Sheet9

  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Set Dic = CreateObject("scripting.dictionary")
  With Sheet10
    sArr = .Range("A5", .Range("A" & Rows.Count).End(xlUp)).Value
    sRow = UBound(sArr)
    sArr2 = .Range("A5").Offset(, .Range("A1").Value - 1).Resize(sRow).Value
  End With
  For i = 1 To sRow
    If Dic.exists(sArr(i, 1)) = False Then Dic.Add sArr(i, 1), sArr2(i, 1)
  Next i

  With Sheet9
    sArr = .Range("D2", .Range("D" & Rows.Count).End(xlUp)).Value
    sRow = UBound(sArr)
    ReDim Res(1 To sRow, 1 To 1)
    For i = 1 To sRow
      Res(i, 1) = Dic.Item(sArr(i, 1))
    Next i
    .Cells(2, jC).Resize(sRow) = Res
  End With
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Code chạy đúng và rất nhanh ạ. Em cảm ơn ANh nhiều ạ !!!

Code Vlookup bị chậm

Phương Phương mito

Thành viên thường trực

Nhattanktnn

Thành viên gắn bó

VetMini

Ăn cùng góc phố

HieuCD

Chuyên gia GPE

Phương Phương mito

Thành viên thường trực

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng