如何在VBA循环中使用Find函数定义产品数据范围

问题根源分析 #

1. FindNext循环失效：原代码未正确设置FindNext的搜索起始位置，且未处理无后续ID的情况，导致循环提前终止。
2. 产品数据范围定位错误：直接在整列搜索"TOTAL"会匹配到第一个结果，而非当前产品对应的结尾，导致数据范围错误。
3. 未限定工作表对象：Range和Cells未指定所属工作表，默认使用激活表，易引发引用错误。
4. 错误处理时机错误：重命名工作表的操作在错误处理设置之前，导致重复ID的错误无法被捕获。

修正后的代码 #

Sub Create_sheets_from_list()
    Dim wb As Workbook
    Dim inputSht As Worksheet
    Dim templateSht As Worksheet
    Dim productStartRng As Range
    Dim productEndRng As Range
    Dim firstIDAddr As String
    Dim productID As String
    Dim newSht As Worksheet
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    Set wb = ThisWorkbook
    Set inputSht = wb.Sheets("Input_data")
    Set templateSht = wb.Sheets("Template")
    
    ' 检查是否存在旧的计算表
    If wb.Sheets(wb.Sheets.Count).Name <> templateSht.Name Then
        MsgBox "请先删除已生成的计算工作表"
        GoTo Cleanup
    End If
    
    ' 定位第一个产品起始位置（ID）
    Set productStartRng = inputSht.Range("A:A").Find(what:="ID", LookIn:=xlValues, LookAt:=xlWhole)
    If productStartRng Is Nothing Then
        MsgBox "未找到任何产品数据（未匹配到ID）"
        GoTo Cleanup
    End If
    firstIDAddr = productStartRng.Address
    
    Do
        ' 从当前ID位置开始，定位对应的TOTAL行
        Set productEndRng = inputSht.Range("A:A").Find(what:="TOTAL", After:=productStartRng, LookIn:=xlValues, LookAt:=xlWhole)
        If productEndRng Is Nothing Then
            MsgBox "产品数据不完整：ID位于" & productStartRng.Address & "，未找到对应的TOTAL"
            GoTo Cleanup
        End If
        
        ' 获取产品ID，为空则跳过
        productID = productStartRng.Offset(1, 0).Value
        If productID = "" Then
            MsgBox "ID位于" & productStartRng.Address & "的产品无有效ID，跳过"
            GoTo NextProduct
        End If
        
        ' 检查是否已存在同名工作表
        On Error Resume Next
        Set newSht = wb.Sheets(productID)
        On Error GoTo Error_DuplicateID
        If newSht Is Nothing Then
            templateSht.Copy After:=wb.Sheets(wb.Sheets.Count)
            Set newSht = wb.Sheets(wb.Sheets.Count)
            newSht.Name = productID
        Else
            MsgBox "工作表" & productID & "已存在，跳过该产品"
            GoTo NextProduct
        End If
        
        ' 填充产品基础信息到新表
        With newSht
            .Range("C2").Value = productID
            .Range("A2").Value = productStartRng.Offset(1, 1).Value ' 产品名称
            .Range("F1").Value = productStartRng.Offset(1, 3).Value ' 重量
            .Range("F2").Value = productStartRng.Offset(1, 4).Value ' 宽度
            .Range("F3").Value = productStartRng.Offset(1, 5).Value ' 高度
            
            ' 复制产品数据区域（ID行下方到TOTAL行上方，A-F列）
            inputSht.Range(productStartRng.Offset(2, 0), productEndRng.Offset(-1, 5)).Copy
            .Range("A4").PasteSpecial xlPasteValuesAndNumberFormats ' 按需调整粘贴方式
            Application.CutCopyMode = False
        End With
        
NextProduct:
        ' 查找下一个产品起始位置
        Set productStartRng = inputSht.Range("A:A").FindNext(After:=productStartRng)
        ' 循环终止条件：回到第一个ID或无更多ID
    Loop While Not productStartRng Is Nothing And productStartRng.Address <> firstIDAddr
    
    MsgBox "所有产品工作表已生成完成"
    
Cleanup:
    Application.ScreenUpdating = True
    inputSht.Activate
    Exit Sub
    
Error_DuplicateID:
    MsgBox "产品ID重复：" & productID & "，请检查并修正后重试"
    GoTo Cleanup
End Sub

关键修改说明 #

1. 明确工作表对象：所有单元格操作均限定为inputSht或newSht，避免跨表引用错误。
2. 精准定位TOTAL：使用Find的After参数，从当前产品的ID位置开始搜索对应的结尾，确保数据范围准确。
3. 完善循环逻辑：增加无后续ID的判断，循环条件确保遍历所有产品后终止。
4. 提前错误处理：在复制工作表前检查是否已存在同名表，捕获重命名时的重复ID错误。
5. 优化数据复制：明确指定产品数据区域，并按需选择粘贴方式（值+数字格式）。

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