How to apply vlookup only for empty cells using vba and another workbook-CodePudding

I want to apply vlookup only on the blank cells through VBA. I am using the below code, but it gives me a Run-time error 13 "Type mismatch".When I run the code step by step via F8, I also get an error 2042 at position If i = "" Then, which also indicates "#N/A".

Dim FileName3 As String

FileName3 = "C:xxxxxx.xlsx"

Dim wb As Workbook: Set wb = ThisWorkbook
Dim lastrow As Long
Dim ws As Worksheet: Set ws = wb.Sheets("Data")
lastrow = ws.cells(Rows.Count, 1).End(xlUp).Row
Dim wb2 As Workbook: Set wb2 = Workbooks.Open(Filename:=FileName3, ReadOnly:=True)
Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Data").Range("S2" & lastrow)
Dim lookupRange As Range: Set lookupRange = wb2.Sheets("Page 1").Range("B2" & lastrow)
Dim i As Range

For Each i In rng
If i = "" Then
i = Application.VLookup(ThisWorkbook.Sheets("Data").Range("A" & i.Row), lookupRange, 2, False)

'MsgBox c.Row
End If
'
Next i
'/////// paste by value

Sheets("Data").Columns(52).Copy
Sheets("Data ").Columns(52).PasteSpecialxlPasteValues
wb2.Close False

ThisWorkbook.Save

I had tried it before with WorksheetFunction.VlookUp, but the same error comes up. The VlookUp should be executed in the datasheet ("Data") in column "S" for all empty cells. The LookUp Values are located in another workbook file. I would appreciate it very much if someone could help me.

CodePudding user response：

VBA VLookup For Blank Cells

Option Explicit

Sub VLookupBlanks()

    Const sFilePath As String = "C:\xxxxxx.xlsx"

    Application.ScreenUpdating = False
    
    Dim swb As Workbook
    Set swb = Workbooks.Open(Filename:=sFilePath, ReadOnly:=True)
    Dim sws As Worksheet: Set sws = swb.Worksheets("Page 1")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "B").End(xlUp).Row
    Dim srg As Range: Set srg = sws.Range("B2:C" & slRow)

    Dim dwb As Workbook: Set dwb = ThisWorkbook
    Dim dws As Worksheet: Set dws = dwb.Worksheets("Data")
    Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
    Dim drg As Range: Set drg = dws.Range("S2:S" & dlRow)
    
    Dim dCell As Range
    Dim dValue As Variant
    
    For Each dCell In drg.Cells
        If Len(CStr(dCell.Value)) = 0 Then
            dValue = Application.VLookup( _
                dCell.EntireRow.Columns("A").Value, srg, 2, False)
            If Not IsError(dValue) Then dCell.Value = dValue
        End If
    Next dCell
 
    swb.Close SaveChanges:=False
    
    With drg.EntireRow.Columns("AZ")
        .Value = .Value
    End With
    
    dwb.Save

    Application.ScreenUpdating = True

    MsgBox "Columns updated.", vbInformation

End Sub

CodePudding user response：

Please, try removing of:

Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Data").Range("S2" & lastrow)
Dim lookupRange As Range: Set lookupRange = wb2.Sheets("Page 1").Range("B2" & lastrow)
Dim i As Range

For Each i In rng
If i = "" Then
i = Application.VLookup(ThisWorkbook.Sheets("Data").Range("A" & i.Row), lookupRange, 2, False)

'MsgBox c.Row
End If
'
Next i

with:

  Dim rngV As Range
  Dim rng As Range: Set rng = ws.Range("S2:S" & lastrow)
  Dim lookupRange As Range: Set lookupRange = wb2.Sheets("Page 1").Range("B2:C" & lastrow)
  On Error Resume Next 'only to avoid an error if no any empty cell exists in rng
   Set rngV = rng.SpecialCells(xlCellTypeBlanks)
  On Error GoTo 0
  If rngV Is Nothing Then Exit Sub 'no any empty cell...
  rngV.Formula = "=Vlookup(A" & rngV.cells(1).row & ", " & lookupRange.Address(external:=True) & ", 2, False)"