针对你的需求，我重构了代码，将所有下拉列表对应的结果汇总到同一个工作表中，同时优化了性能以适配数千条数据的循环场景：

Public Sub ExportToSingleSheet()
    Dim destinationFolder As String
    Dim dataValidationCell As Range, dataValidationListSource As Range, dvValueCell As Range
    Dim targetWB As Workbook, targetWS As Worksheet
    Dim pasteRow As Long
    
    ' 设置结果保存的目标文件夹
    destinationFolder = "C:\Users\DELL 04\Desktop\Q-Book Activities\Experiment"
    If Right(destinationFolder, 1) <> "\" Then destinationFolder = destinationFolder & "\"
    
    ' 开启性能优化（处理数千条数据时大幅提升速度）
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 创建用于汇总的新工作簿和工作表
    Set targetWB = Workbooks.Add
    Set targetWS = targetWB.Worksheets(1)
    targetWS.Name = "汇总数据"
    
    ' 指定带下拉验证的单元格
    Set dataValidationCell = ThisWorkbook.Worksheets("sheet2").Range("G1")
    ' 获取下拉列表的数据源范围
    Set dataValidationListSource = Evaluate(dataValidationCell.Validation.Formula1)
    
    ' 初始化粘贴起始行
    pasteRow = 1
    
    ' 循环处理每个下拉选项
    For Each dvValueCell In dataValidationListSource
        ' 将当前下拉值填入G1，触发数据更新
        dataValidationCell.Value = dvValueCell.Value
        
        ' 复制当前生成的A1:I45数据区域
        dataValidationCell.Worksheet.Range("A1:I45").Copy
        
        ' 粘贴到汇总表的指定行（按需选择粘贴类型）
        targetWS.Cells(pasteRow, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        ' 若需保留格式/公式，可替换为：xlPasteAll
        
        ' 更新下一次粘贴的起始行（跳过已复制的45行）
        pasteRow = pasteRow + 45
    Next dvValueCell
    
    ' 保存汇总工作簿
    targetWB.SaveAs Filename:=destinationFolder & "所有汇总数据.xlsx", FileFormat:=xlWorkbookDefault
    targetWB.Close SaveChanges:=False
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "数据汇总完成！"
End Sub

关键修改说明 #

• 性能优化：关闭屏幕更新和事件触发，避免循环时频繁刷新界面，处理数千条数据时能显著提升效率
• 汇总容器：新建独立工作簿存放结果，不会影响原工作簿的内容
• 粘贴逻辑：用pasteRow变量跟踪每次粘贴的起始位置，确保不同下拉值的结果不会重叠覆盖
• 粘贴类型可选：默认粘贴值和数字格式，若需要保留单元格格式、公式等，可修改Paste参数为xlPasteAll

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