first time

second time

Note: The input meal is data verified – it cannot be something that doesn’t exist on the lookup sheet. The sheets are all named, as are the named ranges.

An (Excel) user picks from meals available and then generates a shopping list PopulateShoppingList().

This takes the selections, looks them up on the applicable sheet, gathers the ingredients and ensures there aren’t duplicate ingredients.

I made some tweaks, refactored some of PopulateShoppingList(), added GetMealList, ExpandArray and IsInArray.

I managed to get rid of my labels in GetIngredients and managed to get the resizing of the array up one level of the code. Still, I feel like I’m missing some refactoring in GetIngredients. Overall I made improvements but it seems like I made the code longer and did not manage to remove much abstraction – there are still 4 For Next loops

Option Explicit  Public Sub PopulateShoppingList()      Dim BreakfastArea As Range     Set BreakfastArea = wsPlan.Range("BreakfastArea")      Dim SnackAreaAM As Range     Set SnackAreaAM = wsPlan.Range("SnacksAreaAM")      Dim LunchArea As Range     Set LunchArea = wsPlan.Range("LunchArea")      Dim SnackAreaPM As Range     Set SnackAreaPM = wsPlan.Range("SnacksAreaPM")      Dim DinnerArea As Range     Set DinnerArea = wsPlan.Range("DinnerArea")      Dim ListArea As Range     Set ListArea = wsPlan.Range("ListArea")     ListArea.ClearContents      Dim ingredientList As Variant     ReDim ingredientList(1, 0)      Dim mealList As Variant     mealList = GetMealList(BreakfastArea)     If Not IsEmpty(mealList) Then GetIngredients wsBreakfast, mealList, ingredientList     mealList = GetMealList(LunchArea)     If Not IsEmpty(mealList) Then GetIngredients wsLunch, mealList, ingredientList     mealList = GetMealList(DinnerArea)     If Not IsEmpty(mealList) Then GetIngredients wsDinner, mealList, ingredientList     mealList = GetMealList(SnackAreaAM)     If Not IsEmpty(mealList) Then GetIngredients wsSnacks, mealList, ingredientList     mealList = GetMealList(SnackAreaPM)     If Not IsEmpty(mealList) Then GetIngredients wsSnacks, mealList, ingredientList       If Not IsEmpty(ingredientList(0, 0)) Then WriteShoppingList ingredientList  End Sub  Private Function GetMealList(ByVal targetArea As Range) As Variant     Dim numberOfMeals As Long     Dim listIndex As Long     listIndex = 0     Dim meal As Range     numberOfMeals = Application.WorksheetFunction.CountA(targetArea)     If numberOfMeals = 0 Then Exit Function     Dim mealList() As String     ReDim mealList(numberOfMeals - 1)     For Each meal In targetArea         If Not meal = vbNullString Then             mealList(listIndex) = meal.Value             listIndex = listIndex + 1         End If     Next     GetMealList = mealList End Function  Private Sub GetIngredients(ByVal targetSheet As Worksheet, ByVal mealList As Variant, ByRef ingredientList As Variant)     Dim sheetRow As Long     Dim mealIndex As Long     Dim mealName As String     Dim mealRow As Long     Dim arrayIndex As Long     Dim sheetLastRow As Long     Dim mealLastRow As Long     Dim expandBy As Long     Dim newIngredient As Long      With targetSheet         sheetLastRow = .Cells(.Rows.count, 2).End(xlUp).Row         For mealIndex = LBound(mealList) To UBound(mealList)             mealName = mealList(mealIndex)             For sheetRow = 2 To sheetLastRow                 If targetSheet.Cells(sheetRow, 1) = mealName Then                     mealLastRow = .Columns(1).Find(what:="*", after:=.Cells(sheetRow, 1), LookIn:=xlValues).Row                     If mealLastRow = 1 Then                         mealLastRow = .Columns(2).Find(what:=vbNullString, after:=.Cells(sheetRow, 2), LookIn:=xlValues).Row                     End If                     newIngredient = UBound(ingredientList, 2)                     expandBy = ExpandArray(.Range(.Cells(sheetRow, 2), .Cells(mealLastRow - 1, 2)), ingredientList)                     ReDim Preserve ingredientList(1, newIngredient + expandBy)                     For mealRow = sheetRow To mealLastRow - 1                          If Not IsInArray(.Cells(mealRow, 2), ingredientList) Then                             ingredientList(0, newIngredient) = .Cells(mealRow, 2)                             ingredientList(1, newIngredient) = .Cells(mealRow, 3)                             newIngredient = newIngredient + 1                         Else:                             For arrayIndex = LBound(ingredientList, 2) To newIngredient                                 If ingredientList(0, arrayIndex) = .Cells(mealRow, 2) Then                                     ingredientList(1, arrayIndex) = ingredientList(1, arrayIndex) + .Cells(mealRow, 3)                                     Exit For                                 End If                             Next arrayIndex                         End If                     Next mealRow                 End If             Next sheetRow         Next mealIndex     End With End Sub  Private Function ExpandArray(ByVal targetRange As Range, ByVal ingredientsList As Variant) As Long     Dim count As Long     Dim ingredient As Variant     Dim newIngredient As Range     For Each newIngredient In targetRange         For Each ingredient In ingredientsList             If ingredient = newIngredient Then GoTo Exists         Next         count = count + 1 Exists:     Next newIngredient     ExpandArray = count End Function  Private Function IsInArray(ByVal ingredient As String, ByVal ingredientList As Variant) As Boolean     Dim element As Variant     For Each element In ingredientList         If element = ingredient Then             IsInArray = True             Exit Function         End If     Next element     IsInArray = False End Function  Private Sub WriteShoppingList(ByVal ingredientList As Variant)     Const LIST_FIRST_ROW As Long = 14     Const LIST_LAST_ROW As Long = 29     Const LIST_FIRST_COLUMN As Long = 2     Const LIST_LAST_COLUMN As Long = 8     Dim arrayIndex As Long     Dim listItem As String      arrayIndex = 0     Dim sheetRow As Long     sheetRow = LIST_FIRST_ROW     Dim columnIndex As Long     columnIndex = LIST_FIRST_COLUMN      For arrayIndex = LBound(ingredientList, 2) To UBound(ingredientList, 2)         listItem = ingredientList(1, arrayIndex) & " " & ingredientList(0, arrayIndex)         If sheetRow > LIST_LAST_ROW Then             columnIndex = columnIndex + 1             sheetRow = LIST_FIRST_ROW             If columnIndex > LIST_LAST_COLUMN Then Exit Sub         End If          wsPlan.Cells(sheetRow, columnIndex) = listItem         sheetRow = sheetRow + 1     Next  End Sub