See if word in column B on sheet 1 is 1 or 0, if 1 lookup word in sheet 2 in row 3 and return list below that word - excel

I have tried to fix a code from the answers that I have found in the forum, but I can't manage.
My issue is:
I have a list of recipes names in the sheet weeks, and I want to decide with a 1 or a 0 which ones I want to meal prep for next week. In sheet Recipes, I have the Recipes listed with their ingredients list below. I would like to have an output of what I need to shop in Sheet 5.
In sheet Weeks If column B = 1, take recipe name in column A; Hlookup recipe name in sheet Recipes row 3, and return list of ingredients below to sheet 3 (the shopping list).
Sub Output_Shoopinglist()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets("Weeks")
Dim LastRow As Long ' get last used row in column b
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Dim DataRange As Range ' get data range
Set DataRange = ws.Range("B3", "C20" & LastRow)
Dim DataArray() As Variant ' read data into an array (for fast processing)
DataArray = DataRange.Value
Dim OutputData As Collection ' create a collection where we collect all desired data
Set OutputData = New Collection
' check each data row and if desired add to collection
Dim iRow As Long
For iRow = LBound(DataArray, 1) To UBound(DataArray, 1)
If DataArray(iRow, 2) = 1 Then
OutputData.Add DataArray(iRow, 1)
End If
Next iRow
Dim wsTemplate As Worksheet
Set wsTemplate = ThisWorkbook.Worksheets("Recipes")
Dim wsVolume As Worksheet
Set wsVolume = ThisWorkbook.Worksheets("Shopping list")
'Lookup Value in Tab Recipes in row 3, and return Ingrediants list one below the other in tab Shopping list in Column B
'Here I am missing code:
End Sub
Here are some screenshots:

I have left comments in few area to explain what the code is doing in general.
As mentioned in the comment - The basic idea is to perform a Find method along the row containing the recipe name and if it is found, the column number of the found cell will be used to pull out the list of ingredients (and the amount that is 1 column before) that is written below the recipe names.
Once the list has been retrieved in an array, it will be used to write into the shopping list worksheet at once.
Option Explicit
Const WSNAME_WEEK As String = "Weeks"
Const WSNAME_RECIPES As String = "Recipes"
Const WSNAME_SHOPPING As String = "Shopping list"
Sub Output_Shoppinglist()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets(WSNAME_WEEK)
Dim lastRow As Long ' get last used row in column b
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Dim DataRange As Range ' get data range
Set DataRange = ws.Range("B4:C" & lastRow)
Dim DataArray() As Variant ' read data into an array (for fast processing)
DataArray = DataRange.Value
Dim OutputData As Collection ' create a collection where we collect all desired data
Set OutputData = New Collection
' check each data row and if desired add to collection
Dim iRow As Long
For iRow = LBound(DataArray, 1) To UBound(DataArray, 1)
If DataArray(iRow, 2) = 1 Then
OutputData.Add DataArray(iRow, 1)
End If
Next iRow
If OutputData.Count <> 0 Then
' Uncomment if you need to clear the shopping list prior to inserting this batch of list of ingredients
' With ThisWorkbook.Worksheets(WSNAME_SHOPPING)
' Dim shoppingLastRow As Long
' shoppingLastRow = .Cells(.Rows.Count, 2).Row
' .Range("A2:B" & shoppingLastRow).Value = ""
' End With
'1. Loop through the collection,
'2. Pass the recipe name to GetIngredients to retrieve the list of ingredients (in an array) from Recipes worksheet
'3. Pass the array to WriteToShoppingList for writing into the Shopping list worksheet
Dim i As Long
For i = 1 To OutputData.Count
'Get the ingredient list from Recipes sheet
Dim ingredList As Variant
ingredList = GetIngredients(OutputData(i))
If Not IsEmpty(ingredList) Then WriteToShoppingList ingredList
Next i
End If
MsgBox "Done!"
End Sub
Function GetIngredients(argRecipeName As String) As Variant
Const firstRow As Long = 7 'Change this to whichever row the first ingredient should be on
Const recipesNameRow As Long = 3
Dim wsTemplate As Worksheet
Set wsTemplate = ThisWorkbook.Worksheets(WSNAME_RECIPES)
'==== Do a Find on row with the recipe names
Dim findCell As Range
Set findCell = wsTemplate.Rows(recipesNameRow).Find(argRecipeName, LookIn:=xlValues, LookAt:=xlWhole)
If Not findCell Is Nothing Then
'==== If found, assign the value of the ingredients (from firstRow to the last row) into an array
Dim lastRow As Long
lastRow = wsTemplate.Cells(firstRow, findCell.Column).End(xlDown).Row
Dim ingredRng As Range
Set ingredRng = wsTemplate.Range(wsTemplate.Cells(firstRow, findCell.Column), wsTemplate.Cells(lastRow, findCell.Column)).Offset(, -1).Resize(, 2)
Dim ingredList As Variant
ingredList = ingredRng.Value
GetIngredients = ingredList
End If
End Function
Sub WriteToShoppingList(argIngredients As Variant)
Dim wsVolume As Worksheet
Set wsVolume = ThisWorkbook.Worksheets(WSNAME_SHOPPING)
Dim lastRow As Long
lastRow = wsVolume.Cells(wsVolume.Rows.Count, 2).End(xlUp).Row
wsVolume.Cells(lastRow + 1, 1).Resize(UBound(argIngredients, 1), 2).Value = argIngredients
End Sub

Related

I need to copy a specific range in multiple sheets and paste them on a final sheet

There are 24 sheets in this workbook. I need to copy the same range from 23 sheets and paste them in a final sheet called "ALL SURVEY". Is there any way to code it in such a way that I don't need to write so much code as I did in the following macro?
Sheets("2").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E2").*PasteSpecial xlPasteValues*
Sheets("3").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E3").*PasteSpecial xlPasteValues*
Sheets("4").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E4").*PasteSpecial xlPasteValues*
Sheets("5").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E5").*PasteSpecial xlPasteValues*
It will be much appreciated if you help me get through this hard task
Thank you
You can use a For...Next loop for this:
Sub Tester()
Dim n As Long, c As Range
Set c = ThisWorkbook.Sheets("ALL SURVEY").Range("E2") 'first destination cell
'loop through sheets
For n = 2 To 23
'convert n to string to get the correct sheet
' Sheets("2") vs Sheets(2) - by sheet Name vs. Index
With ThisWorkbook.Sheets(CStr(n)).Range("U3:X3")
c.Resize(.Rows.Count, .Columns.Count).Value = .Value 'set values
Set c = c.Offset(1, 0) 'next destination
End With
Next n
End Sub
You can do something like this:
Sub copyPaste()
Dim survey_sheet As Worksheet, count As Long
count = 1 'start pasting from this row
For Each survey_sheet In ThisWorkbook.Sheets
If survey_sheet.Name <> "ALL SURVEY" Then
survey_sheet.Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E" & count).PasteSpecial xlPasteValues
count = count + 1
End If
Next survey_sheet
End Sub
As you can see in the macro above, there is a loop For all the sheets in the Workbook. It will end when it has gone through every single one.
The If statement is to avoid copy/pasting in the final sheet ant the count variable is for pasting in the next empty row on "ALL SURVEY" sheet.
Copy Ranges by Rows
Adjust the values in the constants section. Pay attention to the Exceptions List. I added those two 'funny' names just to show that you have to separate them by the Delimiter with no spaces. The list can contain non-existing worksheet names, but it won't help, so remove them and add others if necessary.
You can resize the 'copy' range as you desire (e.g. U3:X5, Z7:AS13). The result will be each next range below the other (by rows).
Basically, the code will loop through all worksheets whose names are not in the Exceptions List and will write the values of the given range to 2D one-based arrays in an Array List. Then it will loop through the arrays of the Array List and copy the values to the resulting Data Array whose values will then be copied to the Destination Range.
The Code
Option Explicit
Sub copyByRows()
Const dstName As String = "ALL SURVEY"
Const dstFirst As String = "E2"
Const srcRange As String = "U3:X3"
Const Delimiter As String = ","
Dim ExceptionsList As String
ExceptionsList = dstName & Delimiter & "Sheet500,Sheet1000"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim dst As Worksheet: Set dst = wb.Worksheets(dstName)
Dim srCount As Long: srCount = dst.Range(srcRange).Rows.Count
Dim cCount As Long: cCount = dst.Range(srcRange).Columns.Count
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, Delimiter)
Dim ws As Worksheet
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
arl.Add ws.Range(srcRange).Value
End If
Next ws
Dim Data As Variant: ReDim Data(1 To arl.Count * srCount, 1 To cCount)
Dim Item As Variant
Dim i As Long
Dim j As Long
Dim k As Long
For Each Item In arl
For i = 1 To srCount
k = k + 1
For j = 1 To cCount
Data(k, j) = Item(i, j)
Next j
Next i
Next Item
dst.Range(dstFirst).Resize(k, cCount).Value = Data
End Sub

How do I set an array's values to be the first row of a worksheet?

I am trying to create an array where values come from the first row of a worksheet, then print those values in another sheet.
I tried to read the first row of Sheet2, store each value in the array until I hit an empty cell, then print that array in the first row of Sheet3.
I'm getting a application defined error in the while loop where I am making sure the row is not equal to Null.
Private Sub createFormatSheet()
With Worksheets("Sheet2")
Dim myTags() As Variant
Dim tag As Variant
Dim rw As Range
Dim i As Integer
i = 1
For Each rw In .Rows
While rw(i, 1) <> Null
myTags = Array(rw(i, 1))
i = i + 1
Wend
Next rw
End With
With Worksheets("Sheet3")
i = 1
For Each tag In myTag
.Cells(i, 1).Value = tag
Next tag
End With
End Sub
Here are two approaches:
Using an array (you don't need to loop through the items
Directly using ranges, no array involved
Step through the code using F8 and see what's going on
Private Sub createFormatSheet()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim startRow As Long
Dim endRow As Long
Dim values As Variant
Set sourceSheet = ThisWorkbook.Worksheets("Sheet2")
Set targetSheet = ThisWorkbook.Worksheets("Sheet3")
' Array approach (no need to loop) source = column 1
startRow = 1
endRow = sourceSheet.Cells(startRow, 1).End(xlDown).Row
values = sourceSheet.Range(sourceSheet.Cells(startRow, 1), sourceSheet.Cells(endRow, 1)).Value
' Target = column 1
targetSheet.Cells(startRow, 1).Resize(endRow, 1).Value = values
' Direct range target column 2
targetSheet.Cells(startRow, 2).Resize(endRow, 1).Value = sourceSheet.Range(sourceSheet.Cells(startRow, 1), sourceSheet.Cells(endRow, 1)).Value
End Sub
Let me know if it works

Unable to populate unique values in third sheet comparing the values of the second sheet to the first one

I've got three sheets - main,specimen and output in an excel workbook. The sheet main and speciment contain some information. Some of the information in two sheets are identical but few of them are not. My intention is to paste those information in output which are available in speciment but not in main.
I've tried like [currently it fills in lots of cells producing duplicates]:
Sub getData()
Dim cel As Range, celOne As Range, celTwo As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("main")
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("specimen")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("output")
For Each cel In ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).row)
For Each celOne In ws1.Range("A2:A" & ws1.Cells(Rows.Count, 1).End(xlUp).row)
If cel(1, 1) <> celOne(1, 1) Then ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).value = celOne(1, 1)
Next celOne
Next cel
End Sub
main contains:
UNIQUE ID FIRST NAME LAST NAME
A0000477 RICHARD NOEL AARONS
A0001032 DON WILLIAM ABBOTT
A0290191 REINHARDT WESTER CARLSON
A0290284 RICHARD WARREN CARLSON
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
A0003916 GEORGES YOUSSEF ACCAOUI
specimen contains:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290284 RICHARD WARREN CARLSON
A0290688 THOMAS A CARLSTROM
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
output should contain [EXPECTED]:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290688 THOMAS A CARLSTROM
How can I achieve that?
If you have the latest version of Excel, with the FILTER function and dynamic arrays, you can do this with an Excel formula.
I changed your Main and Specimen data into tables.
On the Output worksheet you can then enter this formula into a single cell:
=FILTER(specTbl,ISNA(MATCH(specTbl[UNIQUE ID],mnTbl[UNIQUE ID],0)))
The remaining fields will autopopulate with the results.
For a VBA solution, I like to use Dictionaries, and VBA arrays for speed.
'set reference to microsoft scripting runtime
' or use late-binding
Option Explicit
Sub findMissing()
Dim wsMain As Worksheet, wsSpec As Worksheet, wsOut As Worksheet
Dim dN As Dictionary, dM As Dictionary
Dim vMain As Variant, vSpec As Variant, vOut As Variant
Dim I As Long, v As Variant
With ThisWorkbook
Set wsMain = .Worksheets("Main")
Set wsSpec = .Worksheets("Specimen")
Set wsOut = .Worksheets("Output")
End With
'Read data into vba arrays for processing speed
With wsMain
vMain = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
With wsSpec
vSpec = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
'add ID to names dictionary
Set dN = New Dictionary
For I = 2 To UBound(vMain, 1)
dN.Add Key:=vMain(I, 1), Item:=I
Next I
'add missing ID's to missing dictionary
Set dM = New Dictionary
For I = 2 To UBound(vSpec, 1)
If Not dN.Exists(vSpec(I, 1)) Then
dM.Add Key:=vSpec(I, 1), Item:=WorksheetFunction.Index(vSpec, I, 0)
End If
Next I
'write results to output array
ReDim vOut(0 To dM.Count, 1 To 3)
vOut(0, 1) = "UNIQUE ID"
vOut(0, 2) = "FIRST NAME"
vOut(0, 3) = "LAST NAME"
I = 0
For Each v In dM.Keys
I = I + 1
vOut(I, 1) = dM(v)(1)
vOut(I, 2) = dM(v)(2)
vOut(I, 3) = dM(v)(3)
Next v
Dim R As Range
With wsOut
Set R = .Cells(1, 1)
Set R = R.Resize(UBound(vOut, 1) + 1, UBound(vOut, 2))
With R
.EntireColumn.Clear
.Value = vOut
.Style = "Output"
.EntireColumn.AutoFit
End With
End With
End Sub
Both show the same result (except the formula solution does not bring over the column headers; but you can do that with a formula =mnTbl[#Headers] in the cell above the original formula above).
Another option is to join the values of each row in each range and store them in arrays.
Then compare arrays and output the unique values.
In this case, your uniques come from evaluating the whole row, and not just the Unique ID.
Please read code's comments and adjust it to fit your needs.
Public Sub OutputUniqueValues()
Dim mainSheet As Worksheet
Dim specimenSheet As Worksheet
Dim outputSheet As Worksheet
Dim mainRange As Range
Dim specimenRange As Range
Dim mainArray As Variant
Dim specimenArray As Variant
Dim mainFirstRow As Long
Dim specimenFirstRow As Long
Dim outputCounter As Long
Set mainSheet = ThisWorkbook.Worksheets("main")
Set specimenSheet = ThisWorkbook.Worksheets("specimen")
Set outputSheet = ThisWorkbook.Worksheets("output")
' Row at which the output range will be printed (not including headers)
outputCounter = 2
' Process main data ------------------------------------
' Row at which the range to be evaluated begins
mainFirstRow = 2
' Turn range rows into array items
mainArray = ProcessRangeData(mainSheet, mainFirstRow)
' Process specimen data ------------------------------------
' Row at which the range to be evaluated begins
specimenFirstRow = 2
' Turn range rows into array items
specimenArray = ProcessRangeData(specimenSheet, specimenFirstRow)
' Look for unique values and output results in sheet
OutputUniquesFromArrays outputSheet, outputCounter, mainArray, specimenArray
End Sub
Private Function ProcessRangeData(ByVal dataSheet As Worksheet, ByVal firstRow As Long) As Variant
Dim dataRange As Range
Dim evalRowRange As Range
Dim lastRow As Long
Dim counter As Long
Dim dataArray As Variant
' Get last row in sheet (column 1 = column A)
lastRow = dataSheet.Cells(dataSheet.Rows.Count, 1).End(xlUp).Row
' Set the range of specimen sheet
Set dataRange = dataSheet.Range("A" & firstRow & ":C" & lastRow)
' Redimension the array to the number of rows in range
ReDim dataArray(dataRange.Rows.Count)
counter = 0
' Join each row values so it's easier to compare them later and add them to an array
For Each evalRowRange In dataRange.Rows
' Use Trim function if you want to omit the first and last characters if they are spaces
dataArray(counter) = Trim(evalRowRange.Cells(1).Value) & "|" & Trim(evalRowRange.Cells(2).Value) & "|" & Trim(evalRowRange.Cells(3).Value)
counter = counter + 1
Next evalRowRange
ProcessRangeData = dataArray
End Function
Private Sub OutputUniquesFromArrays(ByVal outputSheet As Worksheet, ByVal outputCounter As Long, ByVal mainArray As Variant, ByVal specimenArray As Variant)
Dim specimenFound As Boolean
Dim specimenCounter As Long
Dim mainCounter As Long
' Look for unique values ------------------------------------
For specimenCounter = 0 To UBound(specimenArray)
specimenFound = False
' Check if value in specimen array exists in main array
For mainCounter = 0 To UBound(mainArray)
If specimenArray(specimenCounter) = mainArray(mainCounter) Then specimenFound = True
Next mainCounter
If specimenFound = False Then
' Write values to output sheet
outputSheet.Range("A" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(0)
outputSheet.Range("B" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(1)
outputSheet.Range("C" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(2)
outputCounter = outputCounter + 1
End If
Next specimenCounter
End Sub

Header based column selection and sorting column location

I would like to copy column data based on header and paste it into another sheet on specific location. I have written a code which works perfectly when in the source sheet I have those columns header that I searched for.
Sub Copy()
Dim myCollection(1 To 5) As String
Dim myIterator As Variant
Dim myRng As Range
Dim xlcell As Variant
Dim otherwb As Worksheet
Dim mywb As Workbook
Dim colCounter, i As Integer
Application.ScreenUpdating = False
Set mywb = ThisWorkbook
'Create a collection of header names to search through
myCollection(1) = "Name"
myCollection(2) = "Age"
myCollection(3) = "Region"
myCollection(4) = "Uni"
myCollection(5) = "Grade"
'Where to search, this is the header
Set myRng = mywb.Sheets("Sheet0").Range("A1:E1")
mywb.Worksheets.Add(after:=Worksheets(1)).Name = "Sorted"
Set otherwb = mywb.Sheets("Sorted")
colCounter = 0
'For Each myCollection(i) In myCollection look in each item in the collection
For i = LBound(myCollection) To UBound(myCollection)
' look through each cell in your header
For Each xlcell In myRng.Cells
' when the header matches what you are looking for
If myCollection(i) = xlcell.Value Then
' creating a column index for the new workbook
colCounter = colCounter + 1
mywb.Sheets("Sheet0").Columns(xlcell.Column).Copy
otherwb.Columns(colCounter).Select
otherwb.Paste
End If
Next
Next
otherwb.Range("A1:E1").AutoFilter
End Sub
The problem I am facing now is that for example if it doesn't find header "Uni" in the source sheet then it put column "Grade" on to the 4th column instead of 5th column due to the column counter that I have set. Therefore, I have wrong sequence of column.
However, I would like to create the sorted sheet with defined column header. Therefore, if "Uni" is not available in the source sheet then it should paste "Uni" as a header in the sorted sheet and keep column empty then paste column "Grade".
Regards,
Oliver
Something like this:
So basically you will use Rang.Find to find the name of the Column, if it is found then you can paste it on to the other sheet if it doesn't then it just aste the column header. So your sequence is not Disturbed.
Sub Copy()
Dim myCollection(1 To 5) As String
Dim myIterator As Variant
Dim myRng As Range
Dim xlcell As Variant
Dim otherwb As Worksheet
Dim mywb As Workbook
Dim colCounter, i As Integer
Application.ScreenUpdating = False
Set mywb = ThisWorkbook
'Create a collection of header names to search through
myCollection(1) = "Name"
myCollection(2) = "Age"
myCollection(3) = "Region"
myCollection(4) = "Uni"
myCollection(5) = "Grade"
'Where to search, this is the header
Set myRng = mywb.Sheets("Sheet0").Range("A1:E1")
mywb.Worksheets.Add(after:=Worksheets(1)).Name = "Sorted"
Set otherwb = mywb.Sheets("Sorted")
colCounter = 0
'For Each myCollection(i) In myCollection look in each item in the collection
Dim fnd As Range
For i = LBound(myCollection) To UBound(myCollection)
Set fnd = myRng.Find(myCollection(i))
If Not fnd Is Nothing Then
' creating a column index for the new workbook
colCounter = colCounter + 1
mywb.Sheets("Sheet0").Columns(fnd.Column).Copy
otherwb.Columns(colCounter).Select
otherwb.Paste
Else
colCounter = colCounter + 1
otherwb.Cells(1, colCounter) = myCollection(i)
End If
Next
otherwb.Range("A1:E1").AutoFilter
End Sub
Try this modification:
For Each xlcell In myRng.Cells
colCounter = colCounter + 1 ' increase counter even if header not found
otherwb.Cells(1, colCounter) = myCollection(i) ' write hader even if not found
If myCollection(i) = xlcell.Value Then
' creating a column index for the new workbook
mywb.Sheets("Sheet0").Columns(xlcell.Column).Copy
otherwb.Columns(colCounter).Select
otherwb.Paste
End If
Next
Next
It is not the most elegant solution but it will mend your code.

How to match up data from two spreadsheets using specific format

I am wondering if someone can help me figure out how to match up data from two sheets, in a specific format. Here is an example of the data I need matched up, including an example showing expected output.
Note that UniqueToGroup_IDs are unique to only the specific Group_ID listed. As you can see, both of the sample Group_IDs I listed contain a UniqueToGroup_ID value of XSTN, which will return two different result IDs; 2306765 for Group_ID 16453, and 8272773 for Group_ID 8156705.
I can (painfully) do this semi-manually, by a combination of Text To Columns, adding the Group_ID to the UniqueToGroup_ID and NotUniqueToGroup_ID, and VLOOKUP -- but it takes forever and I need to do this often.
I haven't tried to write any VBA yet, because I'm not sure how to approach this problem. I am not terribly experienced with coding.
See example here (Dropbox)
Thank you in advance, for any advice.
Crazy Lookup
Links
Workbook Download how-to-match-up-data-from-two-spreadsheets-using-specific-format_54299649.xls
The Code
Sub CrazyLookup()
Const cSheet1 As String = "Original Data" ' 1st Source Worksheet Name
Const cSheet2 As String = "Data To Match" ' 2nd Source Worksheet Name
Const cSheet3 As String = "Sample Result" ' Target Worksheet Name
Const cFirstR As Long = 2 ' First Row Number
Const cFirstC As Variant = "A" ' First Column Letter/Number
Const cLastC As Variant = "C" ' Source Worksheet's Last Column
Const cNoC As Long = 2 ' Number of Columns of Target Array/Range
Const cDel As String = "|" ' Split/Join Delimiter
Dim vnt1 As Variant ' 1st Source Array
Dim vnt2 As Variant ' 2nd Source Array
Dim vnt3 As Variant ' Target Array
Dim vntU As Variant ' Unique Array
Dim lastR1 As Long ' Last Row Number of 1st Source Range
Dim lastR2 As Long ' Last Row Number of 2nd Source Range
Dim i As Long ' 1st Source Array Row Counter
Dim j As Long ' Unique Array Row Counter
Dim k As Long ' 2nd Source Array Row Counter
Application.ScreenUpdating = False
On Error GoTo ProcedureExit
' Write 1st Source Range to 1st Source Array.
With ThisWorkbook.Worksheets(cSheet1)
lastR1 = .Columns(.Cells(1, cFirstC).Column) _
.Find("*", , -4123, , 2, 2).Row
vnt1 = .Range(.Cells(cFirstR, cFirstC), .Cells(lastR1, cLastC))
End With
' Write 2nd Source Range to 2nd Source Array.
With ThisWorkbook.Worksheets(cSheet2)
lastR2 = .Columns(.Cells(1, cFirstC).Column) _
.Find("*", , -4123, , 2, 2).Row
vnt2 = .Range(.Cells(cFirstR, cFirstC), .Cells(lastR2, cLastC))
End With
' Resize Target Array TO 1st Source Array's rows count and TO
' Number of Columns of Target Array.
ReDim vnt3(1 To UBound(vnt1), 1 To cNoC)
' Write First Source Array's First Column to Target Array's first column.
For i = 1 To UBound(vnt1)
vnt3(i, 1) = vnt1(i, 1)
Next
' Write
For i = 1 To UBound(vnt1) ' Loop through rows of 1st Source Array.
' Split 1st Source Array's row in 3rd column to Unique Array.
vntU = Split(vnt1(i, 3), cDel)
For j = 0 To UBound(vntU) ' Loop through rows of Unique Array.
For k = 1 To UBound(vnt2) ' Loop through rows of 2nd Source Array.
' Match 1st Source Array's row in 2nd column TO 2nd Source
' Array's row in first column AND Unique Array's row TO
' 2nd Source Array's row in 2nd column.
If vnt1(i, 2) = vnt2(k, 1) And vntU(j) = vnt2(k, 2) Then
' Write from 2nd Source Array's row in 3rd column to
' Unique Array's row.
vntU(j) = vnt2(k, 3)
Exit For ' Stop searching.
End If
Next
' Check if match was not found.
If k > UBound(vnt2) Then vntU(j) = "NotFound"
Next
' Join Unique Array's rows to Target Array's row in second column.
vnt3(i, 2) = Join(vntU, cDel)
Next
With ThisWorkbook.Worksheets(cSheet3)
' Clear contents of Target Range columns (excl. Headers).
.Range(.Cells(cFirstR, cFirstC), .Cells(.Rows.Count, _
.Cells(1, cFirstC).Column + cNoC - 1)).ClearContents
' Copy Target Array to Target Range.
.Cells(cFirstR, cFirstC).Resize(UBound(vnt3), UBound(vnt3, 2)) = vnt3
End With
ProcedureExit:
Application.ScreenUpdating = True
End Sub
You can build a two column cross reference with a dictionary.
Option Explicit
Sub ertgyhj()
Dim i As Long, ii As String, gi As Long, ugi As String, nuid As Long, r As String
Dim a As Long, itm As String, tmp As String, arr As Variant, xref As Object, results As Object
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("original data")
Set ws2 = Worksheets("data to match")
Set ws3 = Worksheets("sample result")
Set xref = CreateObject("scripting.dictionary")
Set results = CreateObject("scripting.dictionary")
'build two column cross reference dictionary
With ws2
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
itm = Join(Array(.Cells(i, "A").Value2, .Cells(i, "B").Value2), Chr(124))
xref.Item(itm) = .Cells(i, "C").Value2
Next i
End With
'put column header labels into results
results.Item("image_id") = "result"
'collect results
With ws1
'loop through rows
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
ii = .Cells(i, "A").Value2
gi = .Cells(i, "B").Value2
ugi = .Cells(i, "C").Value2
tmp = vbNullString
arr = Split(ugi, Chr(124))
'loop through UniqueToGroup_ID and find matches
For a = LBound(arr) To UBound(arr)
itm = Join(Array(gi, arr(a)), Chr(124))
If xref.exists(itm) Then
tmp = IIf(CBool(Len(tmp)), tmp & Chr(124), vbNullString) & xref.Item(itm)
End If
Next a
'store concatenated result with image id
results.Item(ii) = tmp
Next i
End With
'post results
With ws3
.Cells(1, "A").Resize(results.Count, 1) = Application.Transpose(results.keys)
.Cells(1, "B").Resize(results.Count, 1) = Application.Transpose(results.items)
End With
End Sub
I built a workbook that I think can solve your problem. Let me know if this helps!
https://www.dropbox.com/s/3h6mja0xtwucbr5/20180121-Matching.xlsm?dl=0

Resources