如何用VBA循环创建多份Excel文件并完成指定数据处理

先明确需求要点 #

刚好我梳理了你的需求，确保没理解错：

• 源Excel文件包含4个工作表：Type、pivot、Main、Sheet2
• 从Type工作表的L11单元格起始位置读取所有国家代码（如DE、GB、FR）
• 生成目标Excel文件：如果目标文件已存在则删除后重建，新文件必须包含Main view和Overall view两个工作表
• 对源文件的pivot、Main、Sheet2三个工作表分别应用国家代码筛选，将筛选后的有效数据复制到新文件对应工作表中

完整VBA代码 #

把这段代码复制到源文件的模块中（按Alt+F11打开VBA编辑器，插入模块后粘贴）：

Sub GenerateFilteredExcel()
    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim wsType As Worksheet
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim countryCodes As Range
    Dim targetFilePath As String
    Dim filterColumn As Integer ' 这里需要你根据实际情况修改筛选列的序号，比如A列是1，B列是2
    
    ' --------------------------
    ' 配置参数：修改这里的路径和筛选列
    ' --------------------------
    targetFilePath = "C:\Your\Target\Path\FilteredData.xlsx" ' 替换成你的目标文件路径
    filterColumn = 1 ' 假设国家代码在源工作表的A列，根据实际情况修改
    
    ' 设置源工作簿和Type工作表
    Set wbSource = ThisWorkbook
    Set wsType = wbSource.Worksheets("Type")
    
    ' 获取Type表中L11开始的所有国家代码
    Set countryCodes = wsType.Range("L11").End(xlDown)
    If countryCodes.Row < 11 Then
        MsgBox "Type工作表L11及下方未找到国家代码，请检查！", vbExclamation
        Exit Sub
    End If
    Set countryCodes = wsType.Range("L11", countryCodes)
    
    ' 处理目标文件：如果存在则删除
    On Error Resume Next
    Kill targetFilePath
    On Error GoTo 0
    
    ' 新建目标工作簿并创建指定工作表
    Set wbTarget = Workbooks.Add
    ' 删除默认的多余工作表
    Do While wbTarget.Worksheets.Count > 1
        wbTarget.Worksheets(2).Delete
    Loop
    wbTarget.Worksheets(1).Name = "Main view"
    wbTarget.Worksheets.Add(After:=wbTarget.Worksheets("Main view")).Name = "Overall view"
    
    ' 遍历需要处理的源工作表：pivot、Main、Sheet2
    For Each wsSource In wbSource.Worksheets(Array("pivot", "Main", "Sheet2"))
        ' 匹配对应的目标工作表（可根据你的需求调整映射关系）
        Select Case wsSource.Name
            Case "Main"
                Set wsTarget = wbTarget.Worksheets("Main view")
            Case Else
                Set wsTarget = wbTarget.Worksheets("Overall view")
        End Select
        
        ' 清除之前的筛选状态
        If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False
        
        ' 应用多国家代码筛选
        wsSource.UsedRange.AutoFilter Field:=filterColumn, _
            Criteria1:=GetFilterCodeArray(countryCodes), Operator:=xlFilterValues
        
        ' 复制筛选后的可见数据
        wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy
        
        ' 粘贴到目标工作表的起始位置
        wsTarget.Range("A1").PasteSpecial xlPasteAll
        Application.CutCopyMode = False
        
        ' 恢复源工作表的无筛选状态
        wsSource.AutoFilterMode = False
    Next wsSource
    
    ' 保存并关闭目标工作簿
    wbTarget.SaveAs Filename:=targetFilePath, FileFormat:=xlOpenXMLWorkbook
    wbTarget.Close SaveChanges:=False
    
    MsgBox "筛选后的文件已生成：" & targetFilePath, vbInformation
End Sub

' 辅助函数：把国家代码区域转换成筛选可用的数组
Function GetFilterCodeArray(rng As Range) As Variant
    Dim arr() As String
    Dim i As Integer
    ReDim arr(1 To rng.Cells.Count)
    
    For i = 1 To rng.Cells.Count
        arr(i) = rng.Cells(i).Value
    Next i
    
    GetFilterCodeArray = arr
End Function

关键步骤解释 #

1. 参数配置：你需要先修改代码中的targetFilePath为你的目标文件保存路径，filterColumn为源工作表中国家代码所在的列序号（比如A列是1，B列是2）
2. 国家代码读取：通过Range.End(xlDown)自动获取L11开始的所有连续国家代码，避免读取空单元格
3. 目标文件处理：用Kill语句删除已存在的目标文件，通过On Error Resume Next捕获文件不存在的情况，避免报错中断程序
4. 工作表创建：新建工作簿后删除多余的默认工作表，重命名并添加你需要的两个指定工作表
5. 筛选与复制：对每个源工作表应用多值筛选，仅复制可见单元格数据，粘贴到对应目标工作表
6. 辅助函数：把国家代码区域转换成数组，适配AutoFilter的多值筛选需求

注意事项 #

• 确保源工作表的国家代码列没有合并单元格，否则筛选可能出错
• 如果源工作表有表头，复制时可以调整为wsSource.UsedRange.Offset(1,0).SpecialCells(xlCellTypeVisible).Copy来跳过表头
• 运行代码前最好备份源文件，避免意外修改

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