VBA如何通过循环在新建工作簿中添加多工作表并复制指定数据集？

修改后的完整代码 #

Set wsData = Worksheets("DonneesFiltrees")
Application.ScreenUpdating = False

Dim varkey As Variant
Dim wbNew As Workbook
Dim wsNew As Worksheet
Dim sheetName As String

' 提前创建新工作簿，避免循环内重复创建
Set wbNew = Workbooks.Add

For Each varkey In DicTheme.Keys

    Call ChargerLesDonnees(CStr(DicTheme(varkey)), Me.listEntreprise.Value)
    
    If wsData.Range("A2").Value <> "" Then
        sheetName = CStr(DicTheme(varkey))
        
        ' 处理工作表名称非法字符（Excel不允许的字符：/:*?"<>|）
        sheetName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(sheetName, "/", "-"), "\", "-"), ":", "-"), "*", "-"), "?", "-"), """", "-"), "<", "-")
        sheetName = Replace(sheetName, ">", "-")
        sheetName = Replace(sheetName, "|", "-")
        ' 限制名称长度不超过31字符
        If Len(sheetName) > 31 Then sheetName = Left(sheetName, 31)
        
        ' 在新工作簿末尾添加工作表
        Set wsNew = wbNew.Worksheets.Add(After:=wbNew.Worksheets(wbNew.Worksheets.Count))
        ' 设置工作表名称
        wsNew.Name = sheetName
        
        ' 复制DonneesFiltrees的已用数据到新工作表A1开始的位置
        wsData.UsedRange.Copy Destination:=wsNew.Range("A1")
        ' 可选：清除剪贴板，避免弹窗
        Application.CutCopyMode = False
    End If
    
Next varkey

' 删除新工作簿默认的空白工作表（如果有多余的）
Do While wbNew.Worksheets.Count > DicTheme.Count
    Application.DisplayAlerts = False
    wbNew.Worksheets(1).Delete
    Application.DisplayAlerts = True
Loop

' 保存新工作簿
wbNew.SaveAs Filename:=ThisWorkbook.Path & "\data_output\export_du_" & Format(Now(), "DD-MMM-YYYY hh mm AMPM") & ".xlsx", FileFormat:=xlOpenXMLWorkbook

Application.ScreenUpdating = True
' 清理对象
Set wsNew = Nothing
Set wbNew = Nothing
Set wsData = Nothing

关键步骤说明 #

• 提前创建新工作簿：在循环外初始化wbNew，确保所有工作表都添加到同一个工作簿中，而非每次循环新建独立工作簿。
• 处理工作表名称：Excel对工作表名称有字符（禁止/:*?"<>|）和长度（最大31字符）限制，必须提前处理，避免运行报错。
• 高效复制数据：使用UsedRange快速定位DonneesFiltrees的有效数据范围，直接复制到新工作表起始位置，避免冗余操作。
• 清理默认工作表：新建工作簿会自带1-3个空白工作表，循环结束后删除多余的，只保留我们创建的目标工作表。

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