如何用VBA按Excel第8列苹果类别筛选并生成对应工作表？

以下是完整的VBA代码，可实现你描述的功能：

Sub SplitAppleData()
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim appleTypes As Variant
    Dim appleType As Variant
    Dim lastRow As Long
    Dim lastCol As Long
    
    ' 设置源工作表（请将"数据源"改为你实际的工作表名称）
    Set wsSource = ThisWorkbook.Worksheets("数据源")
    
    ' 定义需要处理的苹果类型
    appleTypes = Array("Green Apple", "Red Apple", "Blue Apple")
    
    ' 关闭屏幕更新，提升运行速度
    Application.ScreenUpdating = False
    
    ' 遍历每个苹果类型
    For Each appleType In appleTypes
        ' 检查是否已存在同名工作表，避免重复创建
        On Error Resume Next
        Set wsNew = ThisWorkbook.Worksheets(appleType)
        On Error GoTo 0
        
        ' 不存在则新建工作表
        If wsNew Is Nothing Then
            Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            wsNew.Name = appleType
        End If
        
        ' 回到源表，清除现有筛选
        wsSource.Activate
        If wsSource.AutoFilterMode Then wsSource.AutoFilter.ShowAllData
        
        ' 获取源数据的最后一行和最后一列
        lastRow = wsSource.Cells(wsSource.Rows.Count, 8).End(xlUp).Row
        lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
        
        ' 对第8列筛选当前苹果类型
        wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol)).AutoFilter Field:=8, Criteria1:=appleType
        
        ' 复制筛选后的可见数据到新工作表
        wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol)).SpecialCells(xlCellTypeVisible).Copy wsNew.Range("A1")
        
        ' 自动调整新工作表列宽
        wsNew.Columns.AutoFit
        
        ' 重置对象，用于下一次循环
        Set wsNew = Nothing
    Next appleType
    
    ' 清除源表的筛选
    wsSource.AutoFilter.ShowAllData
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    MsgBox "数据拆分完成！", vbInformation
End Sub

关键说明： #

• 源工作表适配：把代码里的"数据源"替换成你实际存放数据的工作表名称
• 扩展支持：如果后续需要处理Yellow Apple，直接把它加入appleTypes数组即可
• 防重复处理：代码会先检查是否已有对应名称的工作表，避免运行报错
• 精准复制：通过SpecialCells(xlCellTypeVisible)只复制筛选后的可见行，包含表头

使用步骤： #

1. 打开目标Excel工作簿
2. 按Alt + F11打开VBA编辑器
3. 右键点击工作簿名称→插入→模块
4. 将上述代码粘贴到模块中
5. 修改源工作表名称（如有需要）
6. 按F5或点击运行按钮执行宏

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