trjhtr

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

So I was reworking this and came across a few things -

Readability can be improved by renaming some variables in GetIngredients:

 ingredient = .Cells(mealRow, 2)
 quantity = .Cells(mealRow, 3)

Using these instead of the cell makes it much easier to follow.

Also renamed

 sheetRow to currentRow
 mealIndex to listIndex

This also improved readability.

Refactoring GetIngredients

Again, looking back over this I had some comments to myself -

With targetSheet
 sheetLastRow = .Cells(.Rows.count, 2).End(xlUp).Row

 'Set meal
 For listIndex = LBound(mealList) To UBound(mealList)
 mealName = mealList(listIndex)

 For currentRow = 2 To sheetLastRow

 'Find meal, if found EXIT THIS LOOP
 If targetSheet.Cells(currentRow, 1) = mealName Then

 'Find end of meal
 mealLastRow = .Columns(1).Find(what:="*", after:=.Cells(currentRow, 1), LookIn:=xlValues).Row

 'not sure
 If mealLastRow = 1 Then
 mealLastRow = .Columns(2).Find(what:=vbNullString, after:=.Cells(currentRow, 2), LookIn:=xlValues).Row
 End If
 '??
 'current upper bound
 newIngredient = UBound(ingredientList, 2)

 'expand array to include if it doesn't exist. Why can't I use this as the next loop if?
 expandBy = ExpandArray(.Range(.Cells(currentRow, 2), .Cells(mealLastRow - 1, 2)), ingredientList)
 'expand upper bound by count, count can be 0
 ReDim Preserve ingredientList(1, newIngredient + expandBy)

 'Get ingredient
 For mealRow = currentRow To mealLastRow - 1
 ingredient = .Cells(mealRow, 2)
 quantity = .Cells(mealRow, 3)

 'is in list?
 If Not IsInArray(ingredient, ingredientList) Then
 'no, add to list
 ingredientList(0, newIngredient) = ingredient
 ingredientList(1, newIngredient) = quantity
 newIngredient = newIngredient + 1
 Else:
 'yes, increase quantity of existing
 For arrayIndex = LBound(ingredientList, 2) To newIngredient
 If ingredientList(0, arrayIndex) = ingredient Then
 ingredientList(1, arrayIndex) = ingredientList(1, arrayIndex) + quantity
 Exit For
 End If
 Next arrayIndex
 End If
 Next mealRow
 End If
 'why keep looking for something if found?
 Next currentRow
 Next listIndex
End With

It seems I'm doing the same checking in ExpandBy as I am in IsInArray.

It also seems that once I find the meal and populate the ingredients, I continue to iterate through the rest of the sheet, for no reason.

That's sloppy. Why wouldn't I find the ingredient, check in the array then decide to expand the array if it isn't already there?

I also have no idea what the goal of this is -

 If mealLastRow = 1 Then
 mealLastRow = .Columns(2).Find(what:=vbNullString, after:=.Cells(currentRow, 2), LookIn:=xlValues).Row
 End If

At what point will mealLastRow end at 1 when the loop looking for it starts at 2? Maybe there's a bug I don't recognize anymore, but for now I have no idea what that is.

It seems the logical way to do this would be

1. Find the meal on the list


2. Get meal range, find ingredients


3. Look for ingredients in the ingredient array
   
   3a. If found, increase quantity
   
   3b. If not, expand array and add

E.g

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

Public Sub GetIngredients(ByVal targetSheet As Worksheet, ByVal mealList As Variant, ByRef IngredientList As Variant)
 Dim mealIngredients As Variant
 Dim quantity As Long
 Dim ingredient As String
 Dim listIndex As Long
 Dim listPosition As Long
 Dim mealName As String
 Dim mealIndex As Long

 For listIndex = LBound(mealList) To UBound(mealList)
 mealName = mealList(listIndex)
 mealIngredients = FindMeal(mealName, targetSheet)
 For mealIndex = 1 To UBound(mealIngredients)
 ingredient = mealIngredients(mealIndex, 1)
 quantity = mealIngredients(mealIndex, 2)
 listPosition = IngredientPosition(ingredient, IngredientList)

 If listPosition = 0 Then
 ReDim Preserve IngredientList(1, UBound(IngredientList, 2) + 1)
 IngredientList(0, UBound(IngredientList, 2)) = ingredient
 IngredientList(1, UBound(IngredientList, 2)) = quantity
 ElseIf listPosition < 0 Then
 IngredientList(0, listPosition + 2) = ingredient
 IngredientList(1, listPosition + 2) = quantity
 Else
 IngredientList(1, listPosition) = IngredientList(1, listPosition) + quantity
 End If
 Next
 Next listIndex

End Sub

Private Function FindMeal(ByVal mealName As String, ByVal targetSheet As Worksheet) As Variant
 Dim lastRow As Long
 Dim currentRow As Long
 Dim mealLastRow As Long
 With targetSheet
 lastRow = targetSheet.Cells(targetSheet.Rows.count, 2).End(xlUp).Row
 For currentRow = 2 To lastRow
 If targetSheet.Cells(currentRow, 1) = mealName Then
 mealLastRow = .Columns(1).Find(what:="*", after:=.Cells(currentRow, 1), LookIn:=xlValues).Row
 FindMeal = .Range(.Cells(currentRow, 2), .Cells(mealLastRow - 1, 3))
 Exit Function
 End If
 Next
 End With
End Function

Private Function IngredientPosition(ByVal ingredient As String, ByRef IngredientList As Variant) As Long
 If IsEmpty(IngredientList(0, 0)) Then
 IngredientPosition = -2
 Exit Function
 ElseIf IsEmpty(IngredientList(0, 1)) Then
 IngredientPosition = -1
 Exit Function
 Else
 IngredientPosition = 0
 End If

 Dim i As Long
 For i = LBound(IngredientList, 2) To UBound(IngredientList, 2)
 If IngredientList(0, i) = ingredient Then
 IngredientPosition = i
 Exit Function
 End If
 Next

End Function