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