Here is a sample of data from my worksheet. It has been sorted in Column B from smallest to largest to show the duplicate Item Codes (highlighted yellow):
Here is a breakdown of the following columns:
Column A - ID, every ID is unique
Column B - Item Code, duplicates appear
Columns C to E - A range of different data, but if two records have the same Item Code (B), the rest of the data (C to E) will remain the same, as seen above
Columns F to L - Week numbers (52 in a year hence back to 1 in column K) contains numeric values. Despite multiple records could have the same Item Code (B), columns could contain different numeric values (notice the red marks in the above screenshot)
I want to merge these records, based on finding duplicate Item Codes (B), resulting in storing the first ID value (A), merging columns C to E and combing columns F to L. The screenshot below shows my desired output.
As you can see, the records have been combined and merged. Those with a red mark indicate how these numeric values have been added together to show a new value when there are 2 or more records with the same Item Code but have multiple numeric values in the same column. If there is only one value, it merges with the rest to create one row per Item Code.
I have looked online for a long time and all I could find was using Consolidate and using VBA code to combine these records in a format that didn't lead to this desired output, including using formulas.
Thank you!
Edit: The above has been answered. However, below is my original data, I thought the solution for the above question could be easily adjusted and applied to the original data, but I have found no luck with the following code:
Sub ConsolidateItemCodes()
Dim sh As Worksheet, destSh As Worksheet, lastR As Long, arr, arrH, arrVal, arrfin, arrIt
Dim i As Long, j As Long, k As Long, dict As Object
Set sh = Sheets("Sample of Original Data") 'use here the sheet you need processing
Set destSh = sh.Next 'use here the sheet where to return (now in the next sheet)
lastR = sh.Range("F" & sh.Rows.Count).End(xlUp).Row
arrH = sh.Range("A1:CO1").Value2 'the headers
arr = sh.Range("A2:CO" & lastR).Value2 'place the range in an array for faster iteration/processing
ReDim arrVal(0 To 36) 'redim the array keeping the values
'load the dictionary (ItemCodes as unique keys):
Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary object
For i = 1 To UBound(arr)
If Not dict.Exists(arr(i, 6)) Then
For j = 0 To 36: arrVal(j) = arr(i, j + 36): Next j
dict.Add arr(i, 6), Array(Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10), arr(i, 11), arr(i, 12), arr(i, 13), arr(i, 14), arr(i, 15), arr(i, 16), arr(i, 17), arr(i, 18), arr(i, 19), arr(i, 20), arr(i, 21), arr(i, 22), arr(i, 23), arr(i, 24), arr(i, 25), arr(i, 26), arr(i, 27), arr(i, 28), arr(i, 29), arr(i, 30), arr(i, 31), arr(i, 32), arr(i, 33), arr(i, 34), arr(i, 35)), arrVal)
Else
arrIt = dict(arr(i, 6)) 'a dictionary item can be adaptet directly, EXCEPT arrays...
For j = 0 To 36
arrIt(1)(j) = arrIt(1)(j) + arr(i, j + 36)
Next j
dict(arr(i, 6)) = arrIt 'place back the updated jagged array
End If
Next i
'process dictionary content
ReDim arrfin(1 To dict.Count + 1, 1 To UBound(arr, 6))
'place the header in the final array:
For i = 1 To UBound(arrH, 6): arrfin(1, i) = arrH(1, i): Next i
'extract data from dictionary:
k = 1
For j = 0 To dict.Count - 1
k = k + 1
arrIt = dict.Items()(j)
arrfin(k, 1) = arrIt(0)(0): arrfin(k, 2) = arrIt(0)(1): arrfin(k, 3) = arrIt(0)(2): arrfin(k, 4) = arrIt(0)(3): arrfin(k, 5) = arrIt(0)(4): arrfin(k, 6) = dict.keys()(j)
arrfin(k, 7) = arrIt(0)(5): arrfin(k, 8) = arrIt(0)(6): arrfin(k, 9) = arrIt(0)(7): arrfin(k, 10) = arrIt(0)(8): arrfin(k, 11) = arrIt(0)(9): arrfin(k, 12) = arrIt(0)(10): arrfin(k, 13) = arrIt(0)(11): arrfin(k, 14) = arrIt(0)(12): arrfin(k, 15) = arrIt(0)(13): arrfin(k, 16) = arrIt(0)(14): arrfin(k, 17) = arrIt(0)(15): arrfin(k, 18) = arrIt(0)(16): arrfin(k, 19) = arrIt(0)(17): arrfin(k, 20) = arrIt(0)(18): arrfin(k, 21) = arrIt(0)(19): arrfin(k, 22) = arrIt(0)(20): arrfin(k, 23) = arrIt(0)(21): arrfin(k, 24) = arrIt(0)(22): arrfin(k, 25) = arrIt(0)(23): arrfin(k, 26) = arrIt(0)(24): arrfin(k, 27) = arrIt(0)(25): arrfin(k, 28) = arrIt(0)(26): arrfin(k, 29) = arrIt(0)(27): arrfin(k, 30) = arrIt(0)(28): arrfin(k, 31) = arrIt(0)(29): arrfin(k, 32) = arrIt(0)(30): arrfin(k, 33) = arrIt(0)(31): arrfin(k, 34) = arrIt(0)(32): arrfin(k, 35) = arrIt(0)(33)
For i = 0 To 36: arrfin(k, i + 36) = arrIt(1)(i): Next i
Next j
'drop the processed array content at once:
With destSh.Range("A1").Resize(k, UBound(arrfin, 6))
.Value2 = arrfin
.Rows(1).Font.Bold = True
.EntireColumn.AutoFit
End With
MsgBox "Ready..."
End Sub
Here is a snippet of my original data. As you can see column A is the same, column B (2) above is actually column F (6), column F (6) is actually column AJ (36) and it ends at column CO (93).
And this is my desired output, similar to the above.
Please, test the next code. It returns (now) in the next sheet against the processed one, but you can set the destination sheet as you want. As I said in my above comment, it uses arrays and a dictionary and should be very fast. Records can be in any order:
Sub ConsolidateItemCodes()
Dim sh As Worksheet, destSh As Worksheet, lastR As Long, arr, arrH, arrVal, arrfin, arrIt
Dim i As Long, j As Long, k As Long, dict As Object
Set sh = ActiveSheet 'use here the sheet you need processing
Set destSh = sh.Next 'use here the sheet where to return (now in the next sheet)
If sh.FilterMode Then sh.ShowAllData 'to show all data in case of filters...
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arrH = sh.Range("A1:L1").Value2 'the headers
arr = sh.Range("A2:L" & lastR).Value2 'place the range in an array for faster iteration/processing
ReDim arrVal(0 To 6) 'redim the array keeping the values
'load the dictionary (ItemCodes as unique keys):
Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary object
For i = 1 To UBound(arr)
If Not dict.Exists(arr(i, 2)) Then
For j = 0 To 6: arrVal(j) = arr(i, j + 6): Next j
dict.Add arr(i, 2), Array(Array(arr(i, 1), arr(i, 3), arr(i, 4), arr(i, 5)), arrVal)
Else
arrIt = dict(arr(i, 2)) 'a dictionary item can be adaptet directly, EXCEPT arrays...
For j = 0 To 6
arrIt(1)(j) = arrIt(1)(j) + arr(i, j + 6)
Next j
dict(arr(i, 2)) = arrIt 'place back the updated jagged array
End If
Next i
'process dictionary content
ReDim arrfin(1 To dict.count + 1, 1 To UBound(arr, 2))
'place the header in the final array:
For i = 1 To UBound(arrH, 2): arrfin(1, i) = arrH(1, i): Next i
'extract data from dictionary:
k = 1
For j = 0 To dict.count - 1
k = k + 1
arrIt = dict.Items()(j)
arrfin(k, 1) = arrIt(0)(0): arrfin(k, 2) = dict.keys()(j)
arrfin(k, 3) = arrIt(0)(1): arrfin(k, 4) = arrIt(0)(2): arrfin(k, 5) = arrIt(0)(3)
For i = 0 To 6: arrfin(k, i + 6) = arrIt(1)(i): Next i
Next j
'drop the processed array content at once:
With destSh.Range("A1").Resize(k, UBound(arrfin, 2))
.Value2 = arrfin
.rows(1).Font.Bold = True
.EntireColumn.AutoFit
End With
MsgBox "Ready..."
End Sub
I tried commenting all code lines, to be easy understood. If something still not clear enough, do not hesitate to ask for clarifications.
Please, send some feedback after testing it.
Option Explicit
Sub aggregate()
Const ITEM_CODE = "F" ' Item Code
Const WK1 = "AJ" ' start of numeric data
Dim wb As Workbook, ws As Worksheet, n As Long, c1 As Long, c2 As Long
Dim c As Long, r As Long, lastrow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Application.ScreenUpdating = False
With ws
lastrow = .Cells(.Rows.Count, ITEM_CODE).End(xlUp).Row
' start and end columns
c1 = .Columns(WK1).Column
c2 = .UsedRange.Columns.Count + .UsedRange.Column - 1
' scan up sheet
For r = lastrow To 3 Step -1
' compare with row above
If .Cells(r, ITEM_CODE) = .Cells(r - 1, ITEM_CODE) Then
For c = c1 To c2
' aggregate if not blank
If Cells(r, c) <> "" Then
.Cells(r - 1, c) = .Cells(r - 1, c) + .Cells(r, c)
End If
Next
'.Rows(r).Interior.ColorIndex = 3
.Rows(r).Delete
n = n + 1
End If
Next
End With
Application.ScreenUpdating = True
MsgBox n & " rows deleted", vbInformation
End Sub
Related
I have a hard problem that I can't resolve in VBA.
I explain you with a simple example :
I have this database in excel.
my aim is to sum value of apple and apple_1 for column 1,2,3 but for column 4, I want put 1 IFI have just one value who is 1 and 0 IF the 2 value ( apple and apple_1) are 0.
of course, I can have sometimes apple_2 apple_3 apple_4 ... ( I just take an easy example)
Here an example of what I want with VBA :
Please, try the next code. It uses a dictionary and array and due to that it should be fast enough eve for larger ranges:
Sub testProcessFruits()
Dim sh As Worksheet, lastR As Long, arr, arr_, arrIt, arrFin
Dim j As Long, i As Long, dict As Object
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).Row
arr = sh.Range("A1:E" & lastR).Value2
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr)
If InStr(arr(i, 1), "_") > 0 Then
arr_ = Split(arr(i, 1), "_")
If Not dict.Exists(arr_(0)) Then
dict.Add arr_(0), Array(arr(i, 2), arr(i, 3), arr(i, 4))
Else
arrIt = dict(arr_(0))
For j = 0 To UBound(arrIt) - 1
arrIt(j) = arrIt(j) + arr(i, j + 2)
Next j
dict(arr_(0)) = arrIt
End If
Else
If Not dict.Exists(arr(i, 1)) Then
dict.Add arr(i, 1), Array(arr(i, 2), arr(i, 3), arr(i, 4))
Else
arrIt = dict(arr(i, 1))
For j = 0 To UBound(arrIt) - 1
arrIt(j) = arrIt(j) + arr(i, j + 1)
Next j
dict(arr(i, 1)) = arrIt
End If
End If
Next i
ReDim arrFin(1 To dict.count, 1 To 4)
For i = 0 To dict.count - 1
arrFin(i + 1, 1) = dict.Keys()(i)
arrFin(i + 1, 2) = dict.Items()(i)(0)
arrFin(i + 1, 3) = dict.Items()(i)(1)
arrFin(i + 1, 4) = dict.Items()(i)(2)
Next i
With sh.Range("H1")
.Resize(1, 4).Value2 = sh.Range("A1:D1").Value2
.Offset(1).Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin
End With
End Sub
this is really advanced level of macro for me. If anyone could help, i really appreciate it!
I have Data as below.
I want to write a macro that looks for the customerID, ex: if C2=C3, then i want it to look for either the row above or below using column D, fill either up or down (ColumnA, ColumnB, and ColumnD) based on how the data came out. Because the data may come out like Row A2 will be emptied or Row A3 will be emptied but each customer can ONLY have 2 row maxed of data lines.
I will answer based on my comment being true. If not it can be updated afterwards.
I simply just took the basics from my answer I gave yesterday and modified it to meet the conditions of this question. You should be able to see the differences and how easily you can change it to do these sort of tasks.
Sub AddMissingInfo()
Dim ws As Worksheet, lrow As Long, arr, i As Long, j As Long
Set ws = Sheets("Sheet1") 'Change to your sheet name
lrow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row 'Use customerID to find last row, change column if needed
arr = ws.Range("A2:D" & lrow).Value 'Populate the array, change columns/starting row if needed
For i = 1 To UBound(arr, 1) - 1 'Stop loop at line before last (alas the -1)
If arr(i, 3) = arr(i + 1, 3) Then 'Check if customer ID matches the row below
If arr(i, 1) = "" Then 'Checks first name
If arr(i + 1, 1) <> "" Then arr(i, 1) = arr(i + 1, 1)
Else
If arr(i + 1, 1) = "" Then arr(i + 1, 1) = arr(i, 1)
End If
If arr(i, 2) = "" Then 'Checks last name
If arr(i + 1, 2) <> "" Then arr(i, 2) = arr(i + 1, 2)
Else
If arr(i + 1, 2) = "" Then arr(i + 1, 2) = arr(i, 2)
End If
If arr(i, 4) = "" Then 'Checks Order#
If arr(i + 1, 4) <> "" Then arr(i, 4) = arr(i + 1, 4)
Else
If arr(i + 1, 4) = "" Then arr(i + 1, 4) = arr(i, 4)
End If
End If
Next i
ws.Range("A2:D" & lrow).Value = arr 'Dump the info back to the range. Change columns/starting row if needed
End Sub
i got a data input in sheet1 and sheet2 which gets compared. If there is line(s) in sheet1 that match line(s) in sheet2, then copy and paste the whole line to first possible row in sheet3. It needs to match in column C, D, E, H and I to be a totally match. If everything but column H match, then copy/paste line(s) to sheet4 and state the difference in column H.
So my data is set to have 2 matches and 2 amount differences. The 2 that match is fine in sheet3, but the 2 that doesn't match is the problem, as only one of the lines is shown in sheet4.
Can anyone help me please :)
Code so far:
Sub MatchRows()
Dim a As Variant, b As Variant, c As Variant, d As Variant
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim dic As Object, ky As String
Set dic = CreateObject("Scripting.Dictionary")
a = Sheets("Sheet1").Range("A1:I" & Sheets("Sheet1").Range("H" & Rows.Count).End(3).Row).Value
b = Sheets("Sheet2").Range("A1:I" & Sheets("Sheet2").Range("H" & Rows.Count).End(3).Row).Value
ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
ReDim d(1 To UBound(a, 1), 1 To UBound(a, 2))
For i = 2 To UBound(b, 1)
ky = b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5) & "|" & b(i, 9)
dic(ky) = i
Next
For i = 2 To UBound(a, 1)
ky = a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 9)
If dic.exists(ky) Then
j = dic(ky)
If a(i, 8) = b(j, 8) Then
k = k + 1
For n = 1 To UBound(a, 2)
c(k, n) = a(i, n)
Next
c(k, 8) = 0
Else
m = m + 1
For n = 1 To UBound(a, 2)
d(k, n) = a(i, n)
Next
d(k, 8) = a(i, 8) - b(j, 8)
End If
End If
Next
If k > 0 Then Sheets("Sheet3").Range("A" & Rows.Count).End(3)(2).Resize(k, UBound(a, 2)).Value = c
If m > 0 Then Sheets("Sheet4").Range("A" & Rows.Count).End(3)(2).Resize(m, UBound(a, 2)).Value = d
Sheets(3).UsedRange.Columns.AutoFit
Sheets(4).UsedRange.Columns.AutoFit
End Sub
To color the cells set Interior.Color property.
Dim rng as Range
If k > 0 Then
Set rng = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)
With rng.Resize(k, UBound(a, 2))
.Value = c
.Interior.Color = RGB(0, 255, 0) ' green
End With
End If
If m > 0 Then
Set rng = Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Offset(1)
With rng.Resize(m, UBound(a, 2))
.Value = d
.Interior.Color = RGB(255, 0, 0) ' red
End With
End If
Let's say I have this table :
I would want to see :
A follow up from this question:
I can't for the life of me understand this code in order to add more columns. The code work for 'Name, Type, Food' but I need to add 'Place' and 'date'.
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With Feuil1
'Get last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array
arr = .Range("A2:C" & lr).Value
'Loop through array
For x = LBound(arr) To UBound(arr)
If dict.Exists(arr(x, 1) & "|" & arr(x, 2)) Then
dict(arr(x, 1) & "|" & arr(x, 2)) = Join(Array(dict(arr(x, 1) & "|" & arr(x, 2)), arr(x, 3)), ", ")
Else
dict(arr(x, 1) & "|" & arr(x, 2)) = arr(x, 3)
End If
Next x
'Loop through dictionary
For x = 0 To dict.Count - 1
.Cells(x + 2, 8).Resize(, 2).Value = Split(dict.keys()(x), "|")
.Cells(x + 2, 10).Value = dict.items()(x)
Next x
End With
End Sub
Some relative "simple" adjustments would make this work:
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With Sheet1
'Get last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array
arr = .Range("A2:E" & lr).Value
'Loop through array
For x = LBound(arr) To UBound(arr)
If dict.Exists(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) Then
dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) = Join(Array(dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)), arr(x, 3)), ", ")
Else
dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) = arr(x, 3)
End If
Next x
'Loop through dictionary
For x = 0 To dict.Count - 1
.Cells(x + 2, 6).Resize(, 2).Value = Split(Split(dict.keys()(x), "$")(0), "|")
.Cells(x + 2, 8).Value = dict.items()(x)
.Cells(x + 2, 9).Resize(, 2).Value = Split(Split(dict.keys()(x), "$")(1), "|")
Next x
End With
End Sub
Hopefully you'll be able to understand. And all good about the unfortunate wording in your original question. No worries.
Happy coding
Here's a generic function which will return a summarized version of a data table, according the the specified "key" and "value" columns.
(only posted here as your follow-up question is still closed: please do not mark this as an answer here)
Sub Tester()
Dim arr
'summarize the input table
arr = Summarize(ActiveSheet.Range("B2").CurrentRegion, Array(1, 2, 4), Array(3, 5))
'put the output on the sheet
ActiveSheet.Range("h2").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub
'Given an input table rngData (incl. headers), summarize according to
' the "key" columns in arrKeyCols, concatenating values in arrValueCols
' Note: supply column numbers relative to the input range, not the worksheet
' If your table starts in ColB, then the first column is 1, not 2
Function Summarize(rngData As Range, arrKeyCols, arrValueCols)
Dim arr As Variant, arrOut, v
Dim dict As Object, k, r As Long, r2, c As Long, rOut As Long
Set dict = CreateObject("Scripting.Dictionary")
arr = rngData.Value '<< input data, including headers
'Size the output array and copy the headers
' Might have empty "rows" at the end but that's not worth fixing
' given the possible case where no input rows share the same "key"
ReDim arrOut(1 To UBound(arr, 1), 1 To UBound(arr, 2))
For c = 1 To UBound(arr, 2)
arrOut(1, c) = arr(1, c)
Next c
rOut = 2 'start populating output array on this "row"
'loop over the input data
For r = 2 To UBound(arr, 1)
'build the "key" for this row from the key columns passed in arrKeyCols
k = ""
For c = 0 To UBound(arrKeyCols)
k = k & IIf(c > 0, Chr(0), "") & arr(r, arrKeyCols(c))
Next c
'Find the matching row in the output array: if it doesn't exist then create it
If Not dict.exists(k) Then
dict(k) = rOut '<< associate the key with a row in the output array
'populate the key columns in the output array
For c = 0 To UBound(arrKeyCols)
arrOut(rOut, arrKeyCols(c)) = arr(r, arrKeyCols(c))
Next c
r2 = rOut
rOut = rOut + 1 '<< for the next new key
End If
r2 = dict(k) '<< use this row for populating "values" columns
'build the "value" column(s) from arrValueCols
For c = 0 To UBound(arrValueCols)
v = arrOut(r2, arrValueCols(c)) 'extract the existing value
v = v & IIf(Len(v) > 0, ",", "") & arr(r, arrValueCols(c))
arrOut(r2, arrValueCols(c)) = v 're-add the appended value
Next c
Next r
Summarize = arrOut
End Function
I am using a piece of code that loops through a Excel worksheet, uses the keys from it to copy another set of data into it. The two datasets (Dataset A to Dataset B) looks like following:
Dataset A:
Key Val1 Val2 Val3
123 yes up right
324 no down right
314 no up left
Dataset B:
Key Val1 Val2 Val3
123
314
324
When the script is ran, it copies the data based on the Key. My code works for Val1 and Val2, but results in only blank entries for Val3, which is unexpected and unwanted. My code is as follows:
Sub copyData()
Dim i As Long, arr As Variant, dict As Object
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare
With Worksheets("COMBINED")
'put combined!a:d into a variant array
arr = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "D").End(xlUp)).Value2
'loop through array and build dictionary keys from combined!a:a, dictionary item from rows b:d
For i = LBound(arr, 1) To UBound(arr, 1)
dict.Item(arr(i, 1)) = arr(i, 2)
dict.Item(arr(i, 2)) = arr(i, 3)
dict.Item(arr(1, 3)) = arr(1, 4)
Next i
End With
With Worksheets("All SAMs Backlog")
arr = .Range(.Cells(3, "C"), .Cells(.Rows.Count, "C").End(xlUp).Offset(0, 3)).Value2
'loop through array and if c:c matches combined!a:a then put combined!b:b into d:d
For i = LBound(arr, 1) To UBound(arr, 1)
If dict.exists(arr(i, 1)) Then
arr(i, 2) = dict.Item(arr(i, 1))
arr(i, 3) = dict.Item(arr(i, 2))
arr(i, 4) = dict.Item(arr(i, 3))
Else
arr(i, 2) = vbNullString
arr(i, 3) = vbNullString
arr(i, 4) = vbNullString
End If
Next i
'put populated array back into c3 (resized by rows and columns)
.Cells(3, "C").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
MsgBox ("done")
End Sub
Any help is appreciated.
Use Combined column A as the dictionary key and combine the multiple columns into an array to be stored as the dictionary Item
Sub tranferData()
Dim i As Long, arr As Variant, dict As Object
Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare
With Worksheets("COMBINED")
'put combined!a:d into a variant array
arr = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "D").End(xlUp)).Value2
'loop through array and build dictionary keys from combined!a:a, dictionary item from rows b:d
For i = LBound(arr, 1) To UBound(arr, 1)
'add key and multiple items as array
If not dict.exists(arr(i, 1)) Then _
dict.Add Key:=arr(i, 1), Item:=Array(arr(i, 2), arr(i, 3), arr(i, 4))
Next i
End With
With Worksheets("All SAMs Backlog")
arr = .Range(.Cells(3, "C"), .Cells(.Rows.Count, "C").End(xlUp).Offset(0, 3)).Value2
'loop through array and if c:c matches combined!a:a then put combined!b:d into d:f
For i = LBound(arr, 1) To UBound(arr, 1)
If dict.exists(arr(i, 1)) Then
arr(i, 2) = dict.Item(arr(i, 1))(0)
arr(i, 3) = dict.Item(arr(i, 1))(1)
arr(i, 4) = dict.Item(arr(i, 1))(2)
Else
arr(i, 2) = vbNullString
arr(i, 3) = vbNullString
arr(i, 4) = vbNullString
End If
Next i
'put populated array back into c3 (resized by rows and columns)
.Cells(3, "C").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
MsgBox ("done")
End Sub