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]

718

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