Require a steer and a push - VLookups and Multiple Lines in tables

[TheRedCardinal]

Hi all,

I was hoping to get some advice on how to set up a new macro procedure I need to complete.

I've designed something but it's clunky and slow and so there must be a better way (hopefully!)

The situation is this:

• I have an imported table on Worksheet 1, that contains a column called Voucher (currently in B) and 5 columns of blank data to its right
• I have a non-table list in Worksheet 2, that also contains a column headed Voucher (also in B)
• For each row of data in WS1, I need to find the matching voucher in WS2, and then return the data from columns D and F, into columns D and E
• So far, just a simple lookup
• But I also need to check if the voucher exists more than once in WS2 (it can't in WS1) - and if it does, I need a comment adding in column F of WS1 to that effect
• I also need to add a comment if there is no match, but this is done by "IFERROR" right now

There is approximately 10,000 rows of data.

I've been toying with arrays but can't quite make the plan work in my head.

Any tips?

 

[Fluff]

If the value exists more than once in WS2 will the values in D & F be the same every time?

 

[TheRedCardinal]

Hi Fluff - thanks for your help.

The value in column D will be the same. Value in column F will vary (in fact this is reason why the Voucher would be repeated).

My plan would be for a comment to be added saying "Note there was more than 1 instance...."

But even better if a new line could be added underneath the existing one, showing all the same info in A:E but showing the variation in F.

 

[Fluff]

How about concatenating the values in F, would that work?

 

[TheRedCardinal]

Yes it probably would. Would need to do it like =Concatenate (F2 & " , " & F75) but that's easily enough done I think.

 

[Fluff]

Ok, how about

Sub TheRedCardinal()
   Dim Ary As Variant, Nary As Variant
   Dim Dic As Object
   Dim r As Long
   
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Sheet2")
      Ary = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value2
   End With
   For r = 1 To UBound(Ary)
      If Not Dic.Exists(Ary(r, 1)) Then
         Dic.Add Ary(r, 1), Array(Ary(r, 3), Ary(r, 5))
      Else
         Dic(Ary(r, 1)) = Array(Ary(r, 4), Dic(Ary(r, 1))(1) & ", " & Ary(r, 5))
      End If
   Next r
   With Sheets("Sheet1")
      Ary = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).Value2
   End With
   ReDim Nary(1 To UBound(Ary), 1 To 2)
   For r = 1 To UBound(Ary)
      If Dic.Exists(Ary(r, 1)) Then
         Nary(r, 1) = Dic(Ary(r, 1))(0)
         Nary(r, 2) = Dic(Ary(r, 1))(1)
      End If
   Next r
   Sheets("Sheet1").Range("D2").Resize(r - 1, 2).Value = Nary
End Sub

 

[TheRedCardinal]

Hey Fluff,

Thanks for that! It almost works perfectly.

I tried to amend it to work completely but I got a bit lost with Dictionary object bit.

The problems are 2 fold:

First one is my fault, I mixed up columns D and F in my description. So column F will not vary and will be the same, and column D will vary and would be great to concatenate.

However the result when there are 2 matches in column B has ended up being the text in column E of WS2 - which was unexpected!

 

[Fluff]

Getting the col E was my fault (slight typo in the code), this rectifies that & deals with col D changing instead of F

Sub TheRedCardinal()
   Dim Ary As Variant, Nary As Variant
   Dim Dic As Object
   Dim r As Long
   
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Sheet2")
      Ary = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value2
   End With
   For r = 1 To UBound(Ary)
      If Not Dic.Exists(Ary(r, 1)) Then
         Dic.Add Ary(r, 1), Array(Ary(r, 3), Ary(r, 5))
      Else
         Dic(Ary(r, 1)) = Array(Dic(Ary(r, 1))(0) & ", " & Ary(r, 3), Ary(r, 5))
      End If
   Next r
   With Sheets("Sheet1")
      Ary = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).Value2
   End With
   ReDim Nary(1 To UBound(Ary), 1 To 2)
   For r = 1 To UBound(Ary)
      If Dic.Exists(Ary(r, 1)) Then
         Nary(r, 1) = Dic(Ary(r, 1))(0)
         Nary(r, 2) = Dic(Ary(r, 1))(1)
      End If
   Next r
   Sheets("Sheet1").Range("D2").Resize(r - 1, 2).Value = Nary
End Sub

 

[TheRedCardinal]

That seems to work perfectly! Thanks!

I need to study and play with that dictionary element because it looks really useful!

Thanks again!

 

[Fluff]

You're welcome & thanks for the feedback.