Solved: Vlookup formula for unique entries in lists in cells in range?

[Simon Lloyd]

An odd title i know! what i want to achieve is to lookup and display a description for each lookup value. i have a named range caredesc (2 coulmns wide 1st column is short codes i.e AT,ATT etc 2nd column is full description).
If i have a number of cells ( all in in column F) which contains data like this:
PMd, APC, AS, PLS, AT
PMd, ATT, AS, AF, AT
PMd,APC, PLL, AF, ATP
Md, APC, AS, AF, AT
the first 5 codes appear in lets say F4, the next in F5...etc, at the bottom of my report sheet i want a formula that i can copy down that looks up oly the unique values and returns their description, so in Bn display the unique code and in Cn display the full description (where n is the row number). So in column B starting at Bn i would have Pmd, APC,AS,AT, ATT,PLL,AF and in column C starting at Cn i would have 7 descriptions from the lookup value.

Attached is a sample workbook, i would prefer this to be worksheet formulae, i can do it in VBA but there is alread a growing amont in the workbook.

Regards
Simon

[mike31z]

Try this The first code is yours and the 2d code is using formula wizard and i just changed from your name to the actual cell references.

Your code
=VLOOKUP(LEFT(F4,3),CareDesc,2,FALSE)

Modified by me.
=VLOOKUP((LEFT(F4,3)),'Care Codes'!A1:B16,2,0)

I been working on Vlookup for the last three days.

Hope this helps.

mike in wisconsin

[Simon Lloyd]

Mike, thanks for taking a look, the named range Caredesc is in my original workbook which is why it would have shown #Value when you looked at it, the formula you supplied does exactly the same job as mine. What i want is to be able to pull out all the unique values that appear in column F and put them under Care Codes in column B and then lookup the descriptions for them and place those values in column C.......it's quite a bit beyond a standard vlookup as vlookup on its own will not return more than one value nor when you copy down will it remove the previous value from the range so you dont get duplicate results.

Thanks anyway :)

regards,
Simon

[Bob Phillips]

Simon, IMO this is really one where VBA is a better solution. Getting each unique code from within a string is going to be horrendous, if possible.

[mike31z]

When I relook at your column F there are 5 entries seperated by a comma, is this the maximun number of entries or could there be less? Have you considered using more cell that equal the number entries seperated by comma's.

If I under stand this correctly you want one cel to return the full length names for each of the 3 letter references in one cell?

Would consider creating a range of cells that have the full description as the title and how many time that occured or sorted but who preformed the event?

If you put all the 5 events in 1 cell the length would be long and may require more formulas to manage the data.

[Simon Lloyd]

Bob, i had originally used a UDF to separate text from a string but the amount of code was growing and quite frankly getting beyond me to control and maipulate. The Find & Replace method to remove all the "," did not seem to function.....so in the interest of brevity and being able to forge forward with this i changed the layout to:

See attached
so now i have separate columns for each care code for each visit all well and good but when i use this


{=IF(ISERR(INDEX(Carecode1,SMALL(IF(MATCH(Carecode1,Carecode1,0)=ROW(INDIRE CT("1:"&COUNTA(Carecode1))),MATCH(Carecode1,Carecode1,0),""),ROW()-ROW(Carecode1)+1))),"",INDEX(Carecode1,SMALL(IF(MATCH(Carecode1,Carecode1,0)=ROW(INDIRECT("1:"&COUNTA(Carecode1))),MATCH(Carecode1,Carecode1,0),""),ROW()-ROW(Carecode1)+1)))}
i get N/A# carecode1 is defined as
=OFFSET('Generated Report'!$F$4,0,0,COUNTA('Generated Report'!$F:$F),1)carecode2 is column G etc.

is it possible to use the array formula above over a number of columns or do i have to use it singularly for each column as i have done?

I cant see why it isnt returning a value unless its to do with my defined name starting at row 4.

What i intended to do is find the unique values this way and then display the descriptions as a lookup to these.

Regards,
SImon

[Simon Lloyd]

I have worked out a couple of things!, the unique entry array formula i have used requires the list to be contiguos and that it start in row 1, also the formula must also start at row 1 and be copied down from there, getting the formula to only read from row 4 was easy enough but the data still needed to be contiguous from row 1 regardless.

is there any way to ingnore blanks when using this type of formula?
is there a way to use the formula without having contiguous data from row 1?
is there a way of allowing the formula to be used at any location and copied down?

Ideally i want to allow my code to enter the formula at a pre-determined location and copy down for as many entries as have been made, how do i achieve the {} required to commit an array formula?

Regards,
Simon

[Shazam]

Look at the workbook below. I use a couple of helper columns for the formula to work.


Hope it helps!

[Simon Lloyd]

Shazam, thanks for that, i see where your going with it but this report is built using criteria in a userform i.e Client name and all entries between two dates, in reality this could be hundreds of rows, then at the end of the entries i would want the unique care codes and then in the next column do a Vlookup for those entries to give a description, all the formulae would need to be entered using vba, as a static sheet the helper columns work well and could be hidden.

Regards,
SImon

[Bob Phillips]

I am not referring to a UDF Simon, but rather a batch process to extract all unique ids, possibly usng a collection, and then process them.

[Shazam]

Hi Simon Lloyd,


In your first post that has your workbook, Does the data in column F will allways fluctuates? or is the range F4:F10 stay the same?

[Simon Lloyd]

Shazam thanks for your continued efforts with this, but i have changed the layout now because it was holding me up!, now all the data is split up in to its own cells over 5 columns the rows could be from 1 to 1000 or more so i have had to solve it a different way and this is the way it has been tackled!


Sub StartColumnGrab()
Dim AllColumns As String
Dim ThisOne As String
Dim x As Integer
Dim LastRow As Integer
Dim FirstRow As Integer
Dim ThisOneBit As String
Dim ThisOneFound As Boolean
Dim ColToCheck As Integer
Dim SelStart As Integer, SelEnd As String
Dim y As Long
Application.ScreenUpdating = False
Sheets("Generated Report").Visible = True
Sheets("Generated Report").Select
SelStart = Range("A65536").End(xlUp).Row + 1
ColToCheck = 1
FirstRow = Sheets("generated report").Range("A65536").End(xlUp).Offset(4, 0).Row
AllColumns = "F,G,H,I,J,K"
For x = 1 To Len(AllColumns)
If Mid(AllColumns, x, 1) = "," Then
ThisOneFound = True
Else
ThisOneFound = False
ThisOneBit = ThisOneBit + Mid(AllColumns, x, 1)
End If
If ThisOneFound = True Then
CopyColumn (ThisOneBit)
ThisOneBit = ""
End If
Next x
Range("A65536").End(xlUp).Select
LastRow = ActiveCell.Row
For x = LastRow To FirstRow Step -1
If Len(Trim(Cells(x, ColToCheck).Value)) = 0 Then
Rows(x).Select
Selection.Delete Shift:=xlUp
End If
Next x
SelEnd = Range("A65536").End(xlUp).Address
Range("A" & SelStart & ":" & SelEnd).Select
Call KillDupes
Range("A" & SelStart).Select
With Sheets("generated Report")
y = ActiveSheet.UsedRange.Rows.Count
For i = SelStart To y Step 1
If Cells(i, 1).Value = "" Then
ElseIf Cells(i, 1) <> "" Then
Cells(i, 1).Offset(0, 1).Value = "=vlookup(" & Cells(i, 1).Address & ",caredesc,2,false)"
Cells(i, 1).Offset(0, 1).Select
With Selection.Font
.Name = "Verdana"
.FontStyle = "Italic"
.Size = 10
.ColorIndex = 5
End With
End If
Next i
End With
Application.ScreenUpdating = True
End Sub

Sub CopyColumn(pColToUse As String)
Dim RowToUseS As String
Dim RowToUseI As Integer
Dim PasteAtRow
Dim ColsToDo As Integer
Dim ThisCol As String
Dim PosThisCol As Integer
Dim PosEndCol As Integer
Dim EndCol As String
Dim StartRowS As String
Dim StartRowI As Integer
MyColumns = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
"N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", _
"AD", "AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN", "AO", "AP", _
"AQ", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", _
"BD", "BE", "BF", "BG", "BH", "BI", "BJ", "BK", "BL", "BM", "BN", "BO", "BP", _
"BQ", "BR", "BS", "BT", "BU", "BV", "BW", "BX", "BY", "BZ", "CA", "CB", "CC", _
"CD", "CE", "CF", "CG", "CH", "CI", "CJ", "CK", "CL", "CM", "CN", "CO", "CP", _
"CQ", "CR", "CS", "CT", "CU", "CV", "CW", "CX", "CY", "CZ", "DA", "DB", _
"DC", "DD", "DE", "DF", "DG", "DH", "DI", "DJ", "DK", "DL", "DM", "DN", _
"DO", "DP", "DQ", "DR", "DS", "DT", "DU", "DV", "DW", "DX", "DY", "DZ")
For x = 1 To 13 Step 1
If MyColumns(x) = pColToUse Then
PosThisCol = x
End If
Next x

ColsToDo = 1
ThisCol = pColToUse
StartRowS = 4
StartRowI = 4
PosEndCol = PosThisCol + (ColsToDo - 1)
EndCol = MyColumns(PosEndCol)
Range(ThisCol + "65536").End(xlUp).Select
RowToUseI = ActiveCell.Row
RowToUseS = ActiveCell.Row
If RowToUseI >= StartRowI Then
Range(ThisCol + StartRowS + ":" + EndCol + RowToUseS).Select
Selection.Copy
Range(ThisCol + "65536").End(xlUp).Select
Range("A65536").End(xlUp).Select
PasteAtRow = ActiveCell.Row + 1
Cells(PasteAtRow, 1).Select
ActiveSheet.Paste
End If
End Sub
Sub KillDupes()
Dim rConstRange As Range, rFormRange As Range
Dim rAllRange As Range, rCell As Range
Dim iCount As Long
Dim strAdd As String
On Error Resume Next
Set rAllRange = Selection
If WorksheetFunction.CountA(rAllRange) < 2 Then
MsgBox "You selection is not valid", vbInformation
On Error GoTo 0
Exit Sub
End If

Set rConstRange = rAllRange.SpecialCells(xlCellTypeConstants)
Set rFormRange = rAllRange.SpecialCells(xlCellTypeFormulas)
If Not rConstRange Is Nothing And Not rFormRange Is Nothing Then
Set rAllRange = Union(rConstRange, rFormRange)
ElseIf Not rConstRange Is Nothing Then
Set rAllRange = rConstRange
ElseIf Not rFormRange Is Nothing Then
Set rAllRange = rFormRange
Else
MsgBox "You selection is not valid", vbInformation
On Error GoTo 0
Exit Sub
End If
Application.Calculation = xlCalculationManual
For Each rCell In rAllRange
strAdd = rCell.Address
strAdd = rAllRange.Find(What:=rCell, After:=rCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Address
If strAdd <> rCell.Address Then
rCell.Clear
End If
Next rCell
rAllRange.SpecialCells(xlCellTypeBlanks).Delete
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub

Regards,
Simon

[Shazam]

Hi Simon,

Thank you for the info. I got it to work with a few cells like 10 or 11 that will list uniques from those cell base on your first post of that workbook but the range can't go more than that. I think because the formula I'm using is stored in the Define Name Range and it has a limit of 255 characters. Well I'm glad you found a way.

[Simon Lloyd]

Shazam, it wasn't an ideal solution as i have had to redesign lots of things to cope with it, but the end result is smart and neat....don't know how it will react when the list is hundreds of enries long!

Again thanks for your continued efforts.

Regards,
Simon

[johnske]

Hi Simon,

Try this (one small bug - I haven't worked out why, but "PMd" appears twice in the unique list from your attachment)...

Option Explicit

Sub GetCareCodesEtc()

Dim Cell As Range
Dim N As Long

Application.ScreenUpdating = False

With Sheet6
'insert sub-headers
.[B14] = "Care Codes"
.[C14] = "Care Descriptions"
.[B14:C14].Font.Bold = True

'//get care codes used & put under sub-header\\
For Each Cell In .Range("F4", .Range("F" & Rows.Count).End(xlUp).Address)
For N = 0 To UBound(Split(Cell, ","))
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Trim(Split(Cell, ", ")(N))
Next
Next

'//now copy uniques to an unused column & clear this range\\
With .Range("B15", .Range("B" & Rows.Count).End(xlUp).Address)
.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheet6.[IV:IV], _
unique:=True
.ClearContents

'//copy uniques back & clear unused col\\
With Sheet6
.[IV1].CurrentRegion.Copy .[B15]
.[IV:IV].ClearContents
End With '//do a sort just to tidy up\\
.Sort Key1:=Sheet6.[B15], _
Order1:=xlAscending, _
Header:=xlNo, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End With

'//get Care Descriptions\\
.Range("B15", .Range("B" & Rows.Count).End(xlUp)).Offset(0, 1).Formula = _
"=LOOKUP(B15,'Care Codes'!A2:A17,'Care Codes'!B2:B17)"
Application.ScreenUpdating = True
End With
End Sub

[Simon Lloyd]

Johnske, that works very well, thanks for continuing with this even after i marked it solved, the code works well until the duplication of PMd, i re-typed and reformatted to try to remove this - no joy i even modified your code to:

'//now copy uniques to an unused column & clear this range\\
With .Range("B15", .Range("B" & Rows.Count).End(xlUp).Address)
.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheet6.[IV:IV], _
Unique:=True
.ClearContents

'//copy uniques back & clear unused col\\
With Sheet6.[IV1].CurrentRegion
.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheet6.[B15], _
Unique:=True
.ClearContents
but still no joy!, physically did an Advanced filter in place for unique records of the list that had been created by the code and it still doesn't filter out the second PMd - so, there are no trailing spaces, extra characters, hidden characters or formatting and it still sees it as a unique entry?, if there is only 1 PMd in the column then it works fine but add a second and it goes nuts...i even thought that the lower case "d" was causing a problem, changed it to Upper no difference!

Very odd!

Regards,
Simon

[Simon Lloyd]

If i use this:


{=IF(ISERR(INDEX(carecode1,SMALL(IF(MATCH(carecode1,carecode1,0)=ROW(INDIRE CT("1:"&COUNTA(carecode1))),MATCH(carecode1,carecode1,0),""),ROW()-ROW(carecode1)+1))),"",INDEX(carecode1,SMALL(IF(MATCH(carecode1,carecode1,0 )=ROW(INDIRECT("1:"&COUNTA(carecode1))),MATCH(carecode1,carecode1,0),""),ROW()-ROW(carecode1)+1)))}
to get unique entries from the list then there is only 1 PMd.

I could use your code to put the short list in IV and then this formula copied down in column B to get unique entries from that list, however it is an array formula and has to be committed using Ctrl+Shift+Enter but have no idea how to put the formula in place using VBA and then commit it properly!

Regards,
Simon

[johnske]

Yes, very strange - if you repeat the filter on column B it then filters out the duplicate :dunno i.e.
Option Explicit
'
Sub GetCareCodesEtc()
'
Dim Cell As Range
Dim N As Long
'
Application.ScreenUpdating = False
'
With Sheet6
'insert sub-headers
.[B14] = "Care Codes"
.[C14] = "Care Descriptions"
.[B14:C14].Font.Bold = True
'
'//get care codes used & put under sub-header\\
For Each Cell In .Range("F4", .Range("F" & Rows.Count).End(xlUp).Address)
For N = 0 To UBound(Split(Cell, ","))
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Trim(Split(Cell, ", ")(N))
Next
Next
'
'//now copy uniques to an unused column & clear this range\\
With .Range("B15", .Range("B" & Rows.Count).End(xlUp).Address)
.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheet6.[IV:IV], _
unique:=True
.ClearContents
'
'//copy uniques back & clear unused col\\
With Sheet6
.[IV1].CurrentRegion.Copy .[B15]
.[IV:IV].ClearContents
End With '//do a sort just to tidy up\\
.Sort Key1:=Sheet6.[B15], _
Order1:=xlAscending, _
Header:=xlNo, _
MatchCase:=False, _
Orientation:=xlTopToBottom
'
'repeat (bug)
.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheet6.[IV:IV], _
unique:=True
.ClearContents
'
'//copy uniques back & clear unused col\\
With Sheet6
.[IV1].CurrentRegion.Copy .[B15]
.[IV:IV].ClearContents
End With
End With
'
'//get Care Descriptions\\
.Range("B15", .Range("B" & Rows.Count).End(xlUp)).Offset(0, 1).Formula = _
"=LOOKUP(B15,'Care Codes'!A$2:A$17,'Care Codes'!B$2:B$17)"
'
Application.ScreenUpdating = True
'
End With
End Sub

[Simon Lloyd]

I guess thats one for MS (although you never hear of them solving bugs like that!), Johnske again thanks, that code means i can make the worksheet smaller again (better presentation for printout).

Regards,
Simon

[Bob Phillips]

Option Explicit


Sub GetCareCodesEtc()

Dim Cell As Range
Dim N As Long
Dim ary

Application.ScreenUpdating = False

With Sheet6
'insert sub-headers
.Range("B14:C14").Value = Array("Care Codes", "Care Descriptions")
.Range("B14:C14").Font.Bold = True

'//get care codes used & put under sub-header\\
For Each Cell In .Range("F4", .Range("F" & Rows.Count).End(xlUp).Address)
ary = Split(Cell, ",")
For N = LBound(ary) To UBound(ary)
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = ary(N)
Next
Next

'//now copy uniques to an unused column & clear this range\\
With .Range("B14", .Range("B" & Rows.Count).End(xlUp).Address)
.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheet6.Columns("IV:IV"), _
unique:=True
.ClearContents

'//copy uniques back & clear unused col\\
With Sheet6
.Range("IV1").CurrentRegion.Copy .Range("B14")
.Columns("IV:IV").ClearContents
End With '//do a sort just to tidy up\\
.Sort Key1:=Sheet6.Range("B14"), _
Order1:=xlAscending, _
Header:=xlYes, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End With

'//get Care Descriptions\\
.Range("B15", .Range("B" & Rows.Count).End(xlUp)).Offset(0, 1).Formula = _
"=LOOKUP(B15,'Care Codes'!A2:A17,'Care Codes'!B2:B17)"
Application.ScreenUpdating = True
End With
End Sub

[johnske]

Yes, but will give errors without Trim - why the need to include the header row for the filter to work properly Bob?


Option Explicit
'
Sub GetCareCodesEtc()
'
Dim Cell As Range
Dim N As Long
'
Application.ScreenUpdating = False
'
With Sheet6
'insert sub-headers
.[B14:C14] = Array("Care Codes", "Care Descriptions")
.[B14:C14].Font.Bold = True
'
'//get care codes used & put under sub-header\\
For Each Cell In .Range("F4", .Range("F" & Rows.Count).End(xlUp).Address)
For N = 0 To UBound(Split(Cell, ","))
.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Trim(Split(Cell, ",")(N))
Next
Next
'
'//now copy uniques to an unused column & clear this range\\
With .Range("B14", .Range("B" & Rows.Count).End(xlUp).Address)
.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheet6.[IV:IV], _
unique:=True
.ClearContents
'
'//copy uniques back & clear unused col\\
With Sheet6
.[IV1].CurrentRegion.Copy .[B14]
.[IV:IV].ClearContents
End With '//do a sort just to tidy up\\
.Sort Key1:=Sheet6.[B14], _
Order1:=xlAscending, _
Header:=xlYes, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End With
'
'//get Care Descriptions\\
.Range("B15", .Range("B" & Rows.Count).End(xlUp)).Offset(0, 1).Formula = _
"=LOOKUP(B15,'Care Codes'!A$2:A$17,'Care Codes'!B$2:B$17)"
Application.ScreenUpdating = True
End With
'
End Sub

[Simon Lloyd]

Johnske, Bob, with a little bit of this and a little bit of that this is what i have and it works perfect....if there are any things in the code you can do better please feel free as its quite lengthy.

Option Explicit
Sub GetCareCodesEtc()

Dim Cell As Range
Dim N As Long, i, x As Integer
Dim ary
Dim SelStart As Integer, SelEnd As String
Dim SelEndR As Integer
Dim y As Long
Dim rConstRange As Range, rFormRange As Range
Dim rAllRange As Range, rCell As Range
Dim iCount As Long
Dim strAdd As String
Application.ScreenUpdating = False
Sheets("Generated Report").Visible = True
Sheets("Generated Report").Select
SelStart = Range("A65536").End(xlUp).Row + 1

Application.ScreenUpdating = False

With Sheet6
'//get care codes used & put under sub-header\\
For Each Cell In .Range("F4", .Range("F" & Rows.Count).End(xlUp).Address)
ary = Split(Cell, ",")
For N = LBound(ary) To UBound(ary)
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = ary(N)
Next
Next
SelEnd = Range("A65536").End(xlUp).Address
SelEndR = Range("A65536").End(xlUp).Row
Range("A" & SelStart & ":" & SelEnd).Select
''''Remove Duplicates
On Error Resume Next
Set rAllRange = Selection
If WorksheetFunction.CountA(rAllRange) < 2 Then
MsgBox "You selection is not valid", vbInformation
On Error GoTo 0
Exit Sub
End If
Set rConstRange = rAllRange.SpecialCells(xlCellTypeConstants)
Set rFormRange = rAllRange.SpecialCells(xlCellTypeFormulas)
If Not rConstRange Is Nothing And Not rFormRange Is Nothing Then
Set rAllRange = Union(rConstRange, rFormRange)
ElseIf Not rConstRange Is Nothing Then
Set rAllRange = rConstRange
ElseIf Not rFormRange Is Nothing Then
Set rAllRange = rFormRange
Else
MsgBox "You selection is not valid", vbInformation
On Error GoTo 0
Exit Sub
End If
Application.Calculation = xlCalculationManual
For Each rCell In rAllRange
strAdd = rCell.Address
strAdd = rAllRange.Find(What:=rCell, After:=rCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Address
If strAdd <> rCell.Address Then
rCell.Clear
End If
Next rCell
rAllRange.SpecialCells(xlCellTypeBlanks).Delete
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
For x = SelEndR To SelStart Step -1
Cells(x, 1).Value = LTrim(RTrim(Cells(x, 1).Value))
Next x
'''Add formula

Range("A" & SelStart).Select
With Sheets("generated Report")
y = ActiveSheet.UsedRange.Rows.Count
For i = SelStart To y Step 1
If Cells(i, 1).Value = "" Then
GoTo Xit
ElseIf Cells(i, 1) <> "" Then
Cells(i, 1).Offset(0, 1).Value = "=vlookup(" & Cells(i, 1).Address & ",caredesc,2,false)"
Cells(i, 1).Offset(0, 1).Select
With Selection.Font
.Name = "Verdana"
.FontStyle = "Italic"
.Size = 10
.ColorIndex = 5
End With
End If
Next i
Xit:
End With
Application.ScreenUpdating = True
End With
End Sub
Very Kind Regards to you both,
Simon