VBA Copy and Paste Vlookup to Range

avd88

Board Regular
Joined
Jan 18, 2016
Messages
112
Hello,

I have some VBA code I was using where I was looping through a range to add vlookups to a list.
I'm trying to do the same thing for a similar project but have a way larger dataset. 50k lines so it's pretty inefficient to use a loop.

I'm trying to add the formula to the first item on the list and then copy and paste the formula to the range. I did something similar to a concatenation to create the vlookup id's and it worked.
The issue I'm having is the vlookup is copying the formula but it is copying the vlookup for the first item all the way down. I need to formula to act dynamically when I copy and paste the formulas. Any idea on how to solve this?

Here is my code:

VBA Code:
'ADD VLOOKUP AND AUTOFILL QUOTA

j = Worksheets("Upload").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
c = Worksheets("Upload").Range("D:D").Cells.SpecialCells(xlCellTypeConstants).Count + 1

Cells(c, 4).Select
ActiveCell = Application.WorksheetFunction.VLookup(Sheets("Upload").Range("K" & c), Sheets("Quota").Range("A:O"), Sheets("Upload").Range("J2"), False)
Cells(c, 4).Copy
Worksheets("Upload").Range("D" & 3 & ":D" & j).PasteSpecial Paste:=xlPasteFormulas

Worksheets("Upload").Range("D" & 2 & ":D" & j).Copy
Worksheets("Upload").Range("D" & 2 & ":D" & j).PasteSpecial Paste:=xlPasteValues
 
Ok, how about
VBA Code:
Sub avd()
   Dim Ary As Variant, Nary As Variant, Tmp(4 To 15) As Variant
   Dim Dic As Object
   Dim c As Long, r As Long
   
   Set Dic = CreateObject("scripting.dictionary")
   
   With Sheets("pcode")
      Ary = .Range("A1:O" & .Range("A" & Rows.Count).End(xlUp).Row).Value2
   End With
   For r = 1 To UBound(Ary)
      If Not Dic.Exists(Ary(r, 1)) Then
         For c = 4 To 15
            Tmp(c) = Ary(r, c)
         Next c
         Dic.Add Ary(r, 1), Tmp
      End If
   Next r
   With Sheets("Upload")
      Ary = .Range("J2", .Range("K" & Rows.Count).End(xlUp)).Value2
      ReDim Nary(1 To UBound(Ary), 1 To 1)
      For r = 1 To UBound(Ary)
         If Dic.Exists(Ary(r, 2)) Then Nary(r, 1) = Dic(Ary(r, 2))(Ary(r, 1))
      Next r
      .Range("D2").Resize(r - 1).Value = Nary
   End With
End Sub
 
Upvote 0
Solution

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)
Thanks for the reply and your help! Unfortunately I still end up with a blank column, I'll keep trying finding a different method to avoid looping through the whole data set.
 
Upvote 0
Did you get any error messages?
 
Upvote 0
Just got it to work!! I didn't have time until right now to properly look at this. I was replacing the "pcode" worksheet with the result worksheet instead of the lookup table.
Thanks you are the best!

I'll take some time to dissect your code, looks impressive. Definitely above my skillset today.
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0
Hi @Fluff, is there any chance you could help me use the same logic for another section of the same project. I just realize I was having the same issue where I'm copying the value of the first vlookup all the way down. I tried moving around the code that you sent over but I haven't been able to get it.

This one is simpler; I basically need to use the values in column A starting with A2 of the Upload worksheet and vlookup to the 2nd column of the worksheet List of Reps all the way down. Again looping through it is not an option due to the size of the list.

This was the code I was using:

VBA Code:
'ADD VLOOKUP AND AUTOFILL USER ID

c = Worksheets("Upload").Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count + 1
j = Worksheets("Upload").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

Cells(c, 2).Select
ActiveCell = Application.WorksheetFunction.VLookup(Sheets("Upload").Range("A" & c), Sheets("List of Reps").Range("A:B"), 2, False)
Cells(c, 2).Copy
Worksheets("Upload").Range("B" & 3 & ":B" & j).PasteSpecial Paste:=xlPasteFormulas

Worksheets("Upload").Range("B" & 2 & ":B" & j).Copy
Worksheets("Upload").Range("B" & 2 & ":B" & j).PasteSpecial Paste:=xlPasteValues
 
Upvote 0
How about
VBA Code:
Sub avd()
   Dim Ary As Variant, Nary As Variant
   Dim Dic As Object
   Dim c As Long, r As Long
   
   Set Dic = CreateObject("scripting.dictionary")
   c = Sheets("Upload").Range("J2").Value
   
   With Sheets("List of reps")
      Ary = .Range("A1:B" & .Range("A" & 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), Ary(r, c)
   Next r
   With Sheets("Upload")
      Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
      ReDim Nary(1 To UBound(Ary), 1 To 1)
      For r = 1 To UBound(Ary)
         If Dic.Exists(Ary(r, 1)) Then Nary(r, 1) = Dic(Ary(r, 1))
      Next r
      .Range("B2").Resize(r - 1).Value = Nary
   End With
End Sub
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top