Cross reference with partial match and variants

[andysh]

Hi Guys

This one's a belter

I have a list of products which have a prefix and also a list of product variants which have a suffix. The list of variants will always contain items which do not correspond with the list of products e.g.

Product	Qty	Variant	Qty
WHS@CCC	10	BBB@AAA	1
WHS@DDD	5	CCC@AAA	7
WHS@DDD#A	1	CCC@BBB	3
WHS@FFF	3	DDD#A	1
		DDD@AAA	3
		DDD@BBB	2
		EEE@AAA	4
		FFF@AAA	1
		FFF@BBB	2

I need a way of looking up or matching the products in col A and returning the variants and their quantities so I end up with something like:

Product	Qty	Variant	Qty
WHS@CCC	10	CCC@AAA	7
		CCC@BBB	3
WHS@DDD	5	DDD@AAA	3
		DDD@BBB	2
WHS@DDD#A	1	DDD#A	1
WHS@FFF	3	FFF@AAA	1
		FFF@BBB	2

Is this at all possible? The lists could be on different sheets if that makes things easier. Any help would be greatly appreciated.

 

[Yongle]

Members often oversimplify when illustrating problemms of this nature.

So please confirm that ..
- Product always contains @
- Variant always contains @
- the match is always an EXACT match of what comes AFTER the @ in Product with what comes BEFORE the @ in Variant
- Product is in column A, Variant is in column C, (currently) both in the same sheet, with data starting in row 2

Is a VBA solution acceptable ?

 

[andysh]

That's all correct Yongle

There are some products containing # but these will always be an exact match after the product@, there's one in the example

 

[andysh]

Hi

I'm still looking for a solution to this problem.

In answer to Yongle's question above, a VBA solution would be ideal. Something I could assign to a command button so I can paste in a list of products, click the button and see the results.

 

[Yongle]

In answer to Yongle's question above,

ok - will update thread when back at PC later today

 

[Yongle]

(Other than deleting unwanted variants), does this achieve what you want ?

Sub ParitallyMatch()
  
    Dim celP As Range, celV As Range, P As String, V As String, ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Sheets("NameOfSheet")

    Set ws2 = Sheets.Add
    ws1.Range("C:D").Copy ws2.[C1]
    ws2.Range("C:D").Sort ws2.[C2], xlAscending, Header:=xlYes
    ws1.[A1].Resize(, 2).Copy ws2.[A1]
  
For Each celP In ws1.Range("A2:A" & ws1.Range("A" & Rows.Count).End(xlUp).Row)
    For Each celV In ws2.Range("C2:C" & ws2.Range("C" & Rows.Count).End(xlUp).Row)
        On Error Resume Next
        P = Split(celP, "@")(1)
        V = Split(celV, "@")(0)
            If P = V Then
                celV.Resize(, 2).Offset(, -2).Value = celP.Resize(, 2).Value
                Exit For
            End If
    Next celV
Next celP
  
End Sub

 

[andysh]

That's awesome, thanks, it will save me a lot of time.

I know I 'm being really picky but is there a way of adding something to delete the items which aren't a match?

 

[Yongle]

How about ...

Sub ParitallyMatch()
    Application.ScreenUpdating = False
    Dim rngP As Range, celP As Range, rngV As Range, celV As Range, noMatch As Range
    Dim ws1 As Worksheet, ws2 As Worksheet, P As String
    Set ws1 = Sheets("NameOfSheet")
    Set rngP = ws1.Range("A2:A" & ws1.Range("A" & Rows.Count).End(xlUp).Row)
'create new sheet, with variants in columns C&D, sort variants, add headers
    Set ws2 = Sheets.Add
    ws1.Range("C:D").Copy ws2.Range("C1")
    ws2.Range("C:D").Sort ws2.Range("C2"), xlAscending, Header:=xlYes
    ws1.Range("A1:B1").Copy ws2.Range("A1")
    Set rngV = ws2.Range("C2:C" & ws2.Range("C" & Rows.Count).End(xlUp).Row)
    Set noMatch = ws2.Cells(ws2.Rows.Count, 5)
    ws1.Range("A:D").Copy:  ws2.Range("A:D").PasteSpecial (xlPasteColumnWidths)
    ws2.Range("A1").Select
'identify matched products using column E
    For Each celP In rngP
        For Each celV In rngV
             P = Split(celP, "@")(1)
             If P = Split(celV, "@")(0) Then celV.Offset(, 2) = "M"
        Next celV
    Next celP
'create range of unmatched variants and delete those rows
    For Each celV In rngV.Offset(, 2)
        If celV.Value = "" Then Set noMatch = Union(noMatch, celV)
    Next
    noMatch.EntireRow.Delete
    ws2.Columns(5).ClearContents
'add products in columns A&B
    For Each celP In rngP
        For Each celV In rngV
            On Error Resume Next
            P = Split(celP, "@")(1)
                If P = Split(celV, "@")(0) Then
                    celV.Resize(, 2).Offset(, -2).Value = celP.Resize(, 2).Value
                    Exit For
                End If
        Next celV
    Next celP
End Sub

I will post more elegant version tomorrow if above does what you want

 

[andysh]

Astounding!!

You're a legend, Yongle

 

[Yongle]

Here is more elegant version doing same thing as post#8

Sub ParitallyMatchVersion2()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet, cel As Range, celP As Range
    Dim P As String, V As String, i As Long, j As Long, arrP As Variant, arrV As Variant
    Set ws1 = Sheets("NameOfSheet")
    Set ws2 = Sheets.Add
    ws1.Range("A1:D1").Copy
    ws2.Range("A1").PasteSpecial (xlPasteAll)
    ws2.Range("A1").PasteSpecial (xlPasteColumnWidths)
'place values into 2 arrays
    arrP = ws1.Range("A2:B" & ws1.Range("A" & Rows.Count).End(xlUp).Row)
    arrV = ws1.Range("C2:D" & ws1.Range("C" & Rows.Count).End(xlUp).Row)
'write matched values to new sheet
    On Error Resume Next
    Set cel = ws2.Cells(ws2.Rows.Count, 1)
    For i = LBound(arrP, 1) To UBound(arrP, 1)
        P = Split(arrP(i, 1), "@")(1)
        For j = LBound(arrV, 1) To UBound(arrV, 1)
            V = Split(arrV(j, 1), "@")(0)
            If P = V Then cel.End(xlUp).Offset(1).Resize(, 4) = Array(arrP(i, 1), arrP(i, 2), arrV(j, 1), arrV(j, 2))
        Next j
    Next i
'remove values if product is repeated in column A
    For i = cel.End(xlUp).Row To 2 Step -1
        Set celP = ws2.Cells(i, 1)
        If WorksheetFunction.CountIf(ws2.Range("A:A"), celP) > 1 Then celP.Resize(, 2).ClearContents
    Next i
    Exit Sub
End Sub