CODEWITHSUNDEEP
vbaexcelvlookup
HPM
HPM

Reputation: 113

Excel VBA Condtional VLookup

I'm using a VLookup function to screen Tabelle5.Range("A:A") based on identification numbers in Tabelle3.Cells(7 + i, 1). If the identifaction number is found in Tabelle5.Range("A:A") then various cells from this row should be copied to the right cells in (row) Tabelle3.Cells(7 + i, 1). This is working fine with the following code. 

Sub VLookup

Dim lastrow As Long
Dim NFR As Long


lastrow = Tabelle5.Range("A" & Rows.Count).End(xlUp).Row
NFR = Tabelle3.Range("B" & Rows.Count).End(xlUp).Offset(-1).Row
Set myrange = Tabelle5.UsedRange


For i = 2 To lastrow


On Error Resume Next

    If Tabelle3.Cells(7 + i, 1) <> "" And Not IsError(Application.Match(Tabelle3.Cells(7 + i, 1), Tabelle5.Range("A:A"), False)) Then


        Tabelle3.Cells(7 + i, 2) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange, 2, False)


        Tabelle3.Cells(7 + i, 3) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange, 3, False)


        Tabelle3.Cells(7 + i, 4) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange, 4, False)

    End If

Next i

End Sub

My challenge here is that there might be cells in Tabelle3 which do already contain data. This data will be overwritten with the 'new' data from Tabelle5. However, it can occur that the 'new' data from Tabelle5is an empty cell. This would mean, that I would lose data, because a filled cell would be overwritten by an empty cell.

EDIT Does someone know how to apply Vlookup, only if the identification number from Tabelle3.Cells(7 + i, 1) is also found in Tabelle5.Range("A:A") (that's what I'm using Vlookup for) and in a second step only takes not-empty cells from myrange Column 2,3, and 4.

Example The identification number from Tabelle3.Cells(12, 1)is found in Tabelle5.Cells(29,1). Row 29 in Tabelle5contains following values:

In a next step I want my code only copying the 'New Data' from B29 and D29 to the definied cells in Tabelle3 but skipping C29 because it is a empty cell and this might overwrite a already filled cell in Tabelle3.

Upvotes: 0

Views: 190

Answers (2)

FAB
FAB

Reputation: 2569

You could nest your if statement under another if statement, as Banana kindly suggested:

If Tabelle5.Cells(7 + i, 1) <> "" Then

    If Tabelle3.Cells(7 + i, 1) <> "" And Not IsError(Application.Match(Tabelle3.Cells(7 + i, 1), Tabelle5.Range("A:A"), False)) Then

        Tabelle3.Cells(7 + i, 2) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange, 2, False)

        Tabelle3.Cells(7 + i, 3) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange, 3, False)

        Tabelle3.Cells(7 + i, 4) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange, 4, False)

    End If

End If

UPDATED:

In this case you can you use if statements to apply each of your VLookups as this:

If Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange, 2, False) <> "" Then Tabelle3.Cells(7 + i, 2) = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange, 2, False)

or

res1 = Application.WorksheetFunction.VLookup(Tabelle3.Cells(7 + i, 1), myrange, 2, False)
If res1 <> "" Then Tabelle3.Cells(7 + i, 2) = res1

There are surely better ways to this whole logic, but this should help get your code working at least.

Upvotes: 2

Darren Bartrup-Cook
Darren Bartrup-Cook

Reputation: 19722

This method uses FIND to get a reference to the correct cell in column A. It then uses OFFSET to check the values in the various columns before copying the values across.
This assumes the identification numbers are unique on both sheets. 

Public Sub ReplaceFigures()

    Dim rT5_LastCell As Range
    Dim rT3_LastCell As Range
    Dim rCell As Range
    Dim rFound As Range

    'References to last cell in column A.
    Set rT5_LastCell = Tabelle5.Range("A" & Tabelle5.Rows.Count).End(xlUp)
    Set rT3_LastCell = Tabelle3.Range("A" & Tabelle3.Rows.Count).End(xlUp)

    'rcell will be a direct reference to the column A cell in Tabelle3
    'rFound will be a direct reference to the column A cell in Tabelle5 (or nothing).
    With Tabelle5.Range("A1", rT5_LastCell)
        For Each rCell In Tabelle3.Range("A1", rT3_LastCell)
            Set rFound = .Find(What:=rCell, _
                               LookIn:=xlValues, _
                               LookAt:=xlWhole, _
                               SearchDirection:=xlNext)

            If Not rFound Is Nothing Then 'A match has been found.
                'If the Tabelle3 value is empty then copy the Tabelle5 value across.
                If rCell.Offset(, 1) = "" Then rCell.Offset(, 1) = rFound.Offset(, 1) 'column B.
                If rCell.Offset(, 2) = "" Then rCell.Offset(, 2) = rFound.Offset(, 2) 'column C.
                If rCell.Offset(, 3) = "" Then rCell.Offset(, 3) = rFound.Offset(, 3) 'column D.
            End If
        Next rCell
    End With

End Sub

To speed test the macro add the code below and then insert StartTimer at the top of the ReplaceFigures() code and StopTimer at the bottom.

Private Declare Function GetTickCount Lib "kernel32" () As Long

Public CodeTimer As Long

'^^^^^ Top of module ^^^^^^

Public Function StartTimer()
    CodeTimer = GetTickCount
End Function

Public Function StopTimer()
    Dim FinalTime As Long
    FinalTime = GetTickCount - CodeTimer
    MsgBox Format(Now(), "ddd dd-mmm-yy hh:mm:ss") & vbCr & vbCr & _
            Format((FinalTime / 1000) / 86400, "hh:mm:ss") & vbCr & _
            FinalTime & " ms.", vbOKOnly + vbInformation, _
        "Code Timer"
    CodeTimer = 0
End Function

Upvotes: 1

Related Questions