Use Native Excel Function Lookup Formula In VBA

[ramananhrm]

Hi,

I have a query on VBA.

There is a range of cells contains the following words (F4 to F19)

Bridal
Bars
Body Polishing
Clinics
Android
Comics
Lighting
Android
Crystals
Grocery
Waxing
Labs
Flip Phones
Drama
Timer
Flip Phones

There is a sentance 'Aluminium Yoga Bridal Dealers Waxing' in A2


If i try it out in Excel function, i can get the data through the following Excel function
=LOOKUP(2^15,SEARCH(F4:F19,A2),F4:F19)

But when i tried to convert it to the VBA, i receive 'Type mismatch error'

Im not sure where im going wrong.

I have mentioned the code.

Sub fndvalinrng()
Dim rsltrng, srchrng As Range
Dim srch As Integer
srch = ThisWorkbook.Worksheets("Sheet1").Cells(2, 1).Value
Set rsltrng = ThisWorkbook.Worksheets("Sheet1").Range("F4:F19")
Set srchrng = Application.WorksheetFunction.Search(srchrng, srch)

ThisWorkbook.Worksheets("Sheet1").Cells(2, 2).Value = _
Application.WorksheetFunction.Lookup(2 ^ 15, srchrng, rsltrng)

End Sub

Im converting to VBA code because i have a huge dataset.

Please help me out


Regards,
Ramanan

[Excel Fox]

Here's how you do it

Sub fndvalinrng()

    Dim rsltrng As Range
    Dim srch As String

    With ThisWorkbook.Worksheets("Sheet1")
        srch = .Cells(2, 1).Value
        Set rsltrng = .Range("F4:F19")
        .Cells(2, 2).Value = _
        Application.Lookup(2 ^ 15, Application.Search(rsltrng, .Range("A2")), rsltrng)
    End With

End Sub

[ramananhrm]

Hi,

The code is really understandable.

I have one more query on the conversion from Excel formula to VBA (in Array functions)

Here is the scenario.

I have consolidated the non-empty cells. (Range is A2 to A17)

I have used two set of functions (From B2 to B17)

1. =INDEX($A$2:$A$17,SMALL(IF($A$2:$A$17<>"",ROW($A$2 :$A$17)-ROW($A$2)+1),ROWS($B$2:B2))) (Ctrl +Shift + Enter)
2. =INDEX($A$2:$A$17,AGGREGATE(15,6,ROW($A$2:$A$17)-ROW($A$2)+1/($A$2:$A$17<>""),ROWS($B$2:B2)))

A col (Query)
Bridal

Body Polishing
Clinics

Comics
Lighting

Crystals

Waxing


B col (Answer)
Timer
Flip Phones
Bridal
Body Polishing
Clinics
Comics
Lighting
Crystals
Waxing
Timer
Flip Phones


I will have to convert to VBA code because its a huge dataset.

Please help me out if possible.

[Excel Fox]

Post your sample workbook. Maybe a more helpful code can be written.

[Rick Rothstein]

There is a range of cells contains the following words (F4 to F19)

Bridal
Bars
Body Polishing
Clinics
Android
Comics
Lighting
Android
Crystals
Grocery
Waxing
Labs
Flip Phones
Drama
Timer
Flip Phones

There is a sentance 'Aluminium Yoga Bridal Dealers Waxing' in A2

If i try it out in Excel function, i can get the data through the following Excel function
=LOOKUP(2^15,SEARCH(F4:F19,A2),F4:F19)

Can you clarify something for me? The sentence that I highlighted in red contains two words from your list (Bridal and Waxing), but your formula only returns the last one (Waxing); however, if you remove that word (Waxing) from the sentence, then your formula will return first word (Bridal) as it is now the only word in the sentence. Is this the functionality you really wanted? Wouldn't you really want all words from the list that appear in the sentence returned, perhaps as a comma delimited list?

[ramananhrm]

Query.JPG

Here is the sample image

In the attached image, the A2, A5, A8 & A10 cells are empty.
So i used these functions in B Column.

Option 1:
=INDEX($A$1:$A$11,SMALL(IF($A$1:$A$11<>"",ROW($A$1 :$A$11)-ROW($A$1)+1),ROWS($B$1:B1)))
Option 2:
=INDEX($A$2:$A$11,AGGREGATE(15,6,ROW($A$2:$A$11)-ROW($A$2)+1/($A$2:$A$11<>""),ROWS($B$2:B2)))

The B col is listed with non empty cells.

Is it possible to convert these Array functions in VBA, like you did for
=LOOKUP(2^15,SEARCH(F4:F19,A2),F4:F19)

Please help me out.

Regards,
Ramanan

[LalitPandey87]

Here is a code which do not use worksheet functions but do the same work:

Option Explicit


Sub LMP_Test()


    Dim rngRange                As Range
    Dim varArrData()            As Variant
    Dim varArrDataFinal()       As Variant
    Dim lngCount                As Long
    Dim lngLoop                 As Long
    
    Const strDataSheetName      As String = "Sheet1" 'Change accordingly
    Const strDataCell           As String = "A1" 'Change accordingly
    Const strDataResultCell     As String = "B1" 'Change accordingly
    
    With ThisWorkbook.Worksheets(strDataSheetName)
        Set rngRange = .Range(strDataCell)
        Set rngRange = .Range(rngRange, .Cells(.Rows.Count, rngRange.Column).End(xlUp))
        If rngRange.Rows.Count > 1 Then
            varArrData = rngRange.Value
        Else
            ReDim varArrData(1 To 1, 1 To 1)
            varArrData(1, 1) = rngRange.Value
        End If
        Set rngRange = .Range(strDataResultCell)
        lngCount = 0
        rngRange.EntireColumn.ClearContents
        For lngLoop = LBound(varArrData) To UBound(varArrData)
            If Len(Trim(varArrData(lngLoop, 1))) > 0 Then
                rngRange.Offset(lngCount).Value = varArrData(lngLoop, 1)
                lngCount = lngCount + 1
            End If
        Next lngLoop
    End With
    Set rngRange = Nothing
    Erase varArrData
    Erase varArrDataFinal
    lngCount = Empty
    lngLoop = Empty
    
End Sub

[Admin]

Hi,

Try this UDF.

Option Explicit

Function GETNONEMPTYDATA(ByRef Rng As Range, ByVal RowIdx As Long, Optional ByVal ColIdx As Long = 1)
    
    Dim v, e, t(), n As Long
    GETNONEMPTYDATA = CVErr(xlErrRef)
    v = Rng.Columns(ColIdx).Value2
    For Each e In v
        If Len(e) Then
            n = n + 1
            If n = RowIdx Then
                GETNONEMPTYDATA = e
                Exit Function
            End If
        End If
    Next
    
End Function

and use;

in B1 and copied down,

=GETNONEMPTYDATA($A$1:$A$100,ROWS(B$1:B1))

[bakerman]

or a collection

Sub bkrmn()
    Dim sq() As Variant
    
    sn = Sheets("Sheet1").Range("A1:A" & Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row)
    On Error Resume Next
    With New Collection
        For j = 1 To UBound(sn)
            If sn(j, 1) <> vbNullString Then .Add sn(j, 1), CStr(sn(j, 1))
        Next
        ReDim Preserve sq(.Count)
        For i = 1 To .Count
            sq(i - 1) = .Item(i)
        Next
    End With
    On Error GoTo 0
    With Sheets("Sheet1")
        .Columns(2).ClearContents
        .Range("B1").Resize(UBound(sq)) = Application.Transpose(sq)
    End With
End Sub