Excel VBA补全求助：根据选中菜谱自动汇总食材生成购物清单

修正补全后的完整VBA代码 #

Sub Output_Shoppinglist()
    Dim wsWeeks As Worksheet
    Set wsWeeks = ThisWorkbook.Worksheets("Weeks")
    
    ' 获取Weeks表B列最后使用行
    Dim LastRow As Long
    LastRow = wsWeeks.Cells(wsWeeks.Rows.Count, "B").End(xlUp).Row
    
    ' 修正原代码的数据范围错误：读取A3到B最后一行的数据，A列是菜谱名，B列是标记
    Dim DataRange As Range
    Set DataRange = wsWeeks.Range("A3", "B" & LastRow)
    
    Dim DataArray() As Variant
    DataArray = DataRange.Value
    
    Dim OutputRecipes As Collection
    Set OutputRecipes = New Collection
    
    ' 收集所有标记为1的菜谱名称
    Dim iRow As Long
    For iRow = LBound(DataArray, 1) To UBound(DataArray, 1)
        If DataArray(iRow, 2) = 1 Then
            OutputRecipes.Add DataArray(iRow, 1)
        End If
    Next iRow
    
    Dim wsRecipes As Worksheet
    Set wsRecipes = ThisWorkbook.Worksheets("Recipes")
    Dim wsShopping As Worksheet
    Set wsShopping = ThisWorkbook.Worksheets("Shopping list")
    
    ' 先清空购物清单原有内容，避免旧数据干扰
    wsShopping.Cells.Clear
    
    ' 定义购物清单的写入起始行，需要保留表头的话可以修改为2
    Dim writeRow As Long
    writeRow = 1 
    
    Dim recipeName As Variant
    Dim findRng As Range
    Dim ingLastRow As Long
    Dim ingArr As Variant
    Dim j As Long
    
    ' 遍历所有需要导出的菜谱
    For Each recipeName In OutputRecipes
        ' 在Recipes表第3行查找完全匹配的菜谱名称
        Set findRng = wsRecipes.Rows(3).Find(What:=recipeName, LookIn:=xlValues, LookAt:=xlWhole)
        If Not findRng Is Nothing Then
            ' 找到菜谱对应列后，获取该列食材的最后一行
            ingLastRow = wsRecipes.Cells(wsRecipes.Rows.Count, findRng.Column).End(xlUp).Row
            ' 只有存在食材数据才写入
            If ingLastRow > 3 Then
                ' 读取该列第4行到最后一行的所有食材
                ingArr = wsRecipes.Range(wsRecipes.Cells(4, findRng.Column), wsRecipes.Cells(ingLastRow, findRng.Column)).Value
                ' 逐行写入购物清单，自动跳过空单元格
                For j = LBound(ingArr, 1) To UBound(ingArr, 1)
                    If Len(Trim(ingArr(j, 1))) > 0 Then
                        wsShopping.Cells(writeRow, "B").Value = ingArr(j, 1)
                        writeRow = writeRow + 1
                    End If
                Next j
            End If
        End If
    Next recipeName
    
    ' 自动调整购物清单B列列宽
    wsShopping.Columns("B").AutoFit
    MsgBox "购物清单生成完成，共" & writeRow - 1 & "项食材", vbInformation
End Sub

核心调整说明 #

• 修正了原代码中数据范围定义错误的问题，原代码的Range("B3", "C20" & LastRow)写法会导致无法正确读取A列的菜谱名称
• 增加了购物清单旧数据清空逻辑，避免历史数据干扰
• 补全了菜谱匹配、食材读取、写入购物清单的全流程逻辑，自动过滤空食材行
• 新增完成提示，方便确认执行结果

内容的提问来源于stack exchange，提问作者annabelle_123