Vlookup not sufficient - suggestions for combining multiple matche

[m]

Hi,
I have two columns of data that I would like to analyse.
Column A holds a reference number and column B holds the “class†for each of
these reference numbers. Since each reference number can be more than one
class (between 1 and 8) a regular VLOOKUP is not sufficient. The list is
quite long; I have approximately 2000 unique reference numbers.

(Where – indicates new column)

Ref 1 – A
Ref 1 – B
Ref 2 – B
Ref 3 – A
Ref 3 – C

Etc…

What I would like to get out is this:

Ref 1 – A – B
Ref 2 – B
Ref 3 – A – C

Does anybody know how to solve this? I’ve been pulling my hair for two days
now.

 

[Charles Williams]

I would suggest you make a pivot table from the data. It is ideal for this
kind of analysis.

regards
Charles
__________________________________________________
The Excel Calculation Site
http://www.decisionmodels.com

 

[Mike H]

Hi,

Right click your sheet tab, view code and paste this in and run it. Yhe
macro deletes rows so test in a nin-critical workbook

Sub marine()
Dim MyRow As Long
Dim MyColumn As Long
MyColumn = 3
Dim MyRangeA As Range, MyRangeB As Range, MyRange1 As Range
lastrowA = Cells(Rows.Count, "A").End(xlUp).Row
lastrowB = Cells(Rows.Count, "B").End(xlUp).Row
Set MyRangeA = Range("A1:A" & lastrowA)
Set MyRangeB = Range("B2:B" & lastrowB)
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending
For Each a In MyRangeA
If a.Value <> a.Offset(1).Value Then
MyRow = a.Row
For Each B In MyRangeB
If B.Offset(, -1).Value = a Then
Cells(MyRow - 1, MyColumn) = B
MyColumn = MyColumn + 1
End If
Next
MyColumn = 3
End If
Next
For X = 2 To lastrowA
If Cells(X, 1).Value = Cells(X - 1, 1).Value Then
If MyRange1 Is Nothing Then
Set MyRange1 = Cells(X, 1).EntireRow
Else
Set MyRange1 = Union(MyRange1, Cells(X, 1).EntireRow)
End If
End If
Next
MyRange1.Delete
End Sub

Mike

 

[Mike H]

OOPS a bug, try this instead

Sub marine()
Dim MyRow As Long
Dim MyColumn As Long
MyColumn = 3
Dim MyRangeA As Range, MyRangeB As Range, MyRange1 As Range
lastrowA = Cells(Rows.Count, "A").End(xlUp).Row
lastrowB = Cells(Rows.Count, "B").End(xlUp).Row
Set MyRangeA = Range("A1:A" & lastrowA)
Set MyRangeB = Range("B2:B" & lastrowB)
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending
For Each a In MyRangeA
If a.Value <> a.Offset(1).Value Then
MyRow = a.Row
For Each B In MyRangeB
If B.Offset(, -1).Value = a Then
Cells(a.Row, MyColumn) = B
MyColumn = MyColumn + 1
End If
Next
MyColumn = 3
End If
Next
For X = 1 To lastrowA
If Cells(X, 1).Value = Cells(X + 1, 1).Value Then
If MyRange1 Is Nothing Then
Set MyRange1 = Cells(X, 1).EntireRow
Else
Set MyRange1 = Union(MyRange1, Cells(X, 1).EntireRow)
End If
End If
Next
If Not MyRange1 Is Nothing Then
MyRange1.Delete
End If

Mike

 

[Ashish Mathur]

Hi,

Assume that the data below is in range K18:L22. In O18, enter the following
formula and copy down till O22

=K18&COUNTIF($K$18:K18,K18)

In K24:K26, enter Ref1, ref2, Ref3. Also in L16:N16, enter 1,2,3

In In L24, enter the following formula and copy down and across (till N24)

=IF(ISERROR(INDEX($L$18:$O$22,MATCH($K24&L$16,$O$18:$O$22,0),1)),"",INDEX($L$18:$O$22,MATCH($K24&L$16,$O$18:$O$22,0),1))

--
Regards,

Ashish Mathur
Microsoft Excel MVP
www.ashishmathur.com

 

[Mike H]

I should have tested this more thoroughly. last version

Sub marine()
Dim MyRow As Long
Dim MyColumn As Long
MyColumn = 3
Dim MyRangeA As Range, MyRangeB As Range, MyRange1 As Range
lastrowA = Cells(Rows.Count, "A").End(xlUp).Row
lastrowB = Cells(Rows.Count, "B").End(xlUp).Row
Set MyRangeA = Range("A1:A" & lastrowA)
Set MyRangeB = Range("B1:B" & lastrowB)
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending
For Each a In MyRangeA
If a.Value <> a.Offset(1).Value Then
MyRow = a.Row
For Each B In MyRangeB
If B.Offset(, -1).Value = a Then
Cells(a.Row, MyColumn) = B
MyColumn = MyColumn + 1
End If
Next
MyColumn = 3
End If
Next
For X = 1 To lastrowA
If Cells(X, 1).Value = Cells(X + 1, 1).Value Then
If MyRange1 Is Nothing Then
Set MyRange1 = Cells(X, 1).EntireRow
Else
Set MyRange1 = Union(MyRange1, Cells(X, 1).EntireRow)
End If
End If
Next
If Not MyRange1 Is Nothing Then

MyRange1.Delete
Range("B:B").Delete
End If
End Sub


Mike

 

[m]

I don't know enough about VBA to explain it but it seems to be working.

Thanks a lot!

/m

 

[Mike H]

I'm sure there's a simpler solution but I'm glad it worked at the 3rd attempt.

Mike