code vba vlookup thiếu các giá trị sau khi xoá những dòng không mong muốn (1 người xem)

[lhtu]

Em chào các anh/chị,

Em có thực hiện 1 đoạn code cho 1 vấn đề như sau:

Cho bảng

Bảng giá trị để vlookup là


Kết quả mong muốn là xoá những dòng có chứa ô blank hoặc xoá những dòng mà không có giá trị để vlookup (vlookup ra #N/A)

--> Trong VD trên sẽ xóa dòng 4,5 (do không có chứa ô blank) và dòng 3, 6 do có "f" nhưng f lại không có giá trị f trong bảng tham chiếu để vlookup).
--> Kết quả mong muốn


Tuy nhiên, khi chạy code kết quả lại bỏ qua mất việc vlookup các giá trị sau khi xoá dòng có chứa giá trị #N/A

Mong các anh chị góp ý bổ sung và tối ưu đoạn code giúp em ạ.

Private Sub CommandButton1_Click()

Dim i As Integer

Columns("A:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
  
i = 2
Do While Cells(i, 1) <> ""
    Cells(i, 3) = Application.VLookup(Cells(i, 1), Sheets("sheet2").Range("A:C"), 2, False)
        If IsError(Cells(i, 3)) Then
            Cells(i, 1).EntireRow.Delete
        Else
            Cells(i, 3).Value = Cells(i, 3)
        End If
        i = i + 1
Loop

i = 2
Do While Cells(i, 1) <> ""
    Cells(i, 4) = Application.VLookup(Cells(i, 2), Sheets("sheet2").Range("A:C"), 2, False)
        If IsError(Cells(i, 4)) Then
            Cells(i, 1).EntireRow.Delete
        Else
            Cells(i, 4).Value = Cells(i, 4)
        End If
        i = i + 1
Loop

End Sub

Em cảm ơn

 

[quocphuoc88]

Thử xem đúng chưa nhé bạn !

 

[Quang_Hải]

Viết vầy chắc cũng được

Public Sub CommandButton1_Click()
Dim Found As Range, i, j
For i = Sheet1.[A65536].End(3).Row To 1 Step -1
  For j = 1 To 2
      If Cells(i, j) = "" Then Cells(i, j).EntireRow.Delete
      Set Found = Sheet2.[A:A].Find(Cells(i, j), , , 1)
      If Not Found Is Nothing Then
         Cells(i, j + 2) = Found.Offset(, 1)
      Else
         Cells(i, j + 2).EntireRow.Delete
      End If
  Next
Next
End Sub

 

[chuot0106]

Viết vầy chắc cũng được

Public Sub CommandButton1_Click()
Dim Found As Range, i, j
For i = Sheet1.[A65536].End(3).Row To 1 Step -1
  For j = 1 To 2
      If Cells(i, j) = "" Then Cells(i, j).EntireRow.Delete
      Set Found = Sheet2.[A:A].Find(Cells(i, j), , , 1)
      If Not Found Is Nothing Then
         Cells(i, j + 2) = Found.Offset(, 1)
      Else
         Cells(i, j + 2).EntireRow.Delete
      End If
  Next
Next
End Sub

Quá chuẩn rồi anh ạ!

 

[lhtu]

Thử xem đúng chưa nhé bạn !

Anh cho em hỏi thêm:

Endr = .Range("A65000").End(xlUp).Row --> tại sao chỉ giới hạn A đến 65000 mà không kéo cho hết sheet (đối với excel 2007 trở đi là được hơn 1 triệu dòng).

.cells() thì dấu "." trước cells() ý nghĩa là gì.

Nếu với mỗi giá trị ở mỗi cột có 2 giá trị cần vlookup thì lúc đó code sẽ như thế nào ạ? (sẽ có 4 cột giá trị mới C, D, E, Fthay vì 2 cột giá trị mới C, D như ví dụ trước)

Em cảm ơn.

 

[chuot0106]

Anh cho em hỏi thêm:

Endr = .Range("A65000").End(xlUp).Row --> tại sao chỉ giới hạn A đến 65000 mà không kéo cho hết sheet (đối với excel 2007 trở đi là được hơn 1 triệu dòng).

.cells() thì dấu "." trước cells() ý nghĩa là gì.

Endr = .Range("A65000").End(xlUp).Row --> tại sao chỉ giới hạn A đến 65000 mà không kéo cho hết sheet (đối với excel 2007 trở đi là được hơn 1 triệu dòng).
Đây là code viết cho excel 2003 nên chỉ giới hạn tới 65000. (65536 dòng)
Còn nếu excel 2007 thì hơn.
.cells() thì dấu "." trước cells() ý nghĩa là gì?
Bạn để ý trong code ban quocphuong có viết "With Sheet1 ....End With" không? Dấu "." trước cell là thay cho "sheet1" đó. Nếu không viết With sheet1 thì tất cả những chỗ có dấu "." phải viết rõ là "sheet1".
P/S: Viết như vậy code sẽ ngắn gọn hơn!
Thân!!!!

 

[lhtu]

khi chạy code trên thì gặp vấn đề khi lượng dữ liệu lớn -> khi chạy excel báo overflow -> vậy có cách nào khắc phục vấn đề này không ạ.

 

[Quang_Hải]

khi chạy code trên thì gặp vấn đề khi lượng dữ liệu lớn -> khi chạy excel báo overflow -> vậy có cách nào khắc phục vấn đề này không ạ.

Đưa file có cấu trúc dữ liệu thật và lượng dữ liệu tương đối thì cách gì mà chả có chứ. Thấy kiểu dữ liệu tạm chẳng ai muốn suy nghĩ đâu.
Cái loại xoá xoá tìm tìm thì mình bảo đảm xử lý 10000 dòng chưa tới 1 giây

 

[lhtu]

Đưa file có cấu trúc dữ liệu thật và lượng dữ liệu tương đối thì cách gì mà chả có chứ. Thấy kiểu dữ liệu tạm chẳng ai muốn suy nghĩ đâu.
Cái loại xoá xoá tìm tìm thì mình bảo đảm xử lý 10000 dòng chưa tới 1 giây

Dear anh,

Em gửi dữ liệu thật (tầm khoảng 1 triệu dòng), file nặng chưa đưa được lên diễn đàn nên trước em gửi ví dụ tạm.

Do dung lượng file khoảng hơn 4MB, nên em up lên trang mediafire.


Anh xem giúp em ạ.

 

[quocphuoc88]

Thử xem được chưa nhé bạn ! ( dữ liệu của bạn kinh quá gần 1tr dòng, hehe )

Sub GPE()
Dim Dic As Object, i As Long, Endr As Long, Tmp As String
Dim Arr(), j As Long, KQ(), Sarr(), Obj1 As String, Obj2 As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet2
        Endr = .Range("A1048576").End(xlUp).Row
        Arr = .Range("A2:C" & Endr)
        For i = 1 To Endr - 1
            Tmp = CStr(Arr(i, 1))
            If Not Dic.Exists(Tmp) Then
                Dic.Add Tmp, i
            End If
        Next i
    End With
    
    With Sheet1
        Endr = .Range("A1048576").End(xlUp).Row
        If Endr > 1 Then
            ReDim KQ(1 To Endr - 1, 1 To 6)
            Sarr = .Range("A2:B" & Endr)
            For i = 1 To Endr - 1
                Obj1 = CStr(Sarr(i, 1))
                Obj2 = CStr(Sarr(i, 2))
                If Dic.Exists(Obj1) And Dic.Exists(Obj2) Then
                    j = j + 1
                    KQ(j, 1) = Sarr(i, 1)
                    KQ(j, 2) = Sarr(i, 2)
                    KQ(j, 3) = Arr(Dic.Item(Obj1), 2)
                    KQ(j, 4) = Arr(Dic.Item(Obj1), 3)
                    KQ(j, 5) = Arr(Dic.Item(Obj2), 2)
                    KQ(j, 6) = Arr(Dic.Item(Obj2), 3)
                End If
            Next i
            .Range("A2:B" & Endr).ClearContents
            If j Then .Range("A2").Resize(j, 6).Value = KQ
        End If
    End With
    
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

Quên nói bạn :
- do bạn nói là sẽ xóa dòng những Object nào rỗng hoặc dò không có bên sheet2 nên mình dùng cách không đi tìm rồi xóa liền mà sau khi xong hết nó sẽ xóa toàn bộ dữ liệu cũ và gán dữ liệu mới vào !

 

[lhtu]

Code chạy rất nhanh và chuẩn ạ