Vlookup Multiple Values By Adding Formula With Loop In VBA

[LalitPandey87]

Then it can be done with the help of VBA Macro. Is it Ok?

[Safal Shrestha]

Ok. Thanks

Regards,
Safal

[LalitPandey87]

Try this:

Sub LMP_Test()

    Dim rngData                     As Range
    Dim rngFirstValue               As Range
    Dim rngValue                    As Range
    Dim varResult()                 As Variant
    Dim strFindWhat                 As String
    Dim lngCount                    As Long
    
    Const strShtName                As String = "calcs"
    Const strDataStartCell          As String = "C4"
    Const strCriteriaCell           As String = "D11"
    Const strResultCell             As String = "C15"
    Const strBlankArrayVal          As String = "ArrayIsBlankWithNoDataFound"
    
    With Worksheets(strShtName)
        Set rngData = .Range(strDataStartCell).CurrentRegion
        strFindWhat = .Range(strCriteriaCell).Value
        With rngData.Resize(, 1)
            Set rngValue = .Find(strFindWhat, LookIn:=xlValues)
            If Not rngValue Is Nothing Then
                Set rngFirstValue = rngValue
                Set rngValue = Nothing
                lngCount = 1
                ReDim varResult(1 To lngCount)
                varResult(LBound(varResult)) = strBlankArrayVal
                Do
                    If rngValue Is Nothing Then
                        Set rngValue = .FindNext(rngFirstValue)
                        varResult(lngCount) = rngValue.Offset(, 1).Value
                    Else
                        lngCount = lngCount + 1
                        Set rngValue = .FindNext(rngValue)
                        ReDim Preserve varResult(1 To lngCount)
                        varResult(lngCount) = rngValue.Offset(, 1).Value
                    End If
                Loop While Not rngValue Is Nothing And rngValue.Address <> rngFirstValue.Address
            End If
        End With
        If varResult(LBound(varResult)) <> strBlankArrayVal Then
            .Range(strResultCell).Resize(10000).ClearContents
            varResult = Application.Transpose(varResult)
            .Range(strResultCell).Resize(UBound(varResult), 1).Value = varResult
        End If
    End With
    
    Set rngData = Nothing
    Set rngFirstValue = Nothing
    Set rngValue = Nothing
    Erase varResult
    strFindWhat = vbNullString
    lngCount = Empty

End Sub

[Safal Shrestha]

Is the code working with the sheet I have attached? Because it is showing Run time 9 error. Or do I have to change anything in the code?

Thanx

[LalitPandey87]

It is working fine as i already tested it with your attached file.
There are some constants there you can change it if required.

[Safal Shrestha]

Can you please attach the workbook you worked on? Thanks.

[LalitPandey87]

I tested it again on your attached file and it is working fine. Restart your system and then check it again may be it will work.