VBA遍历筛选列复制筛选结果到目标文件无内容问题求助

你的代码无法完成复制粘贴，是几个显性逻辑错误叠加导致的：

• 工作簿打开逻辑错误：循环打开14个tech文件时，每次都覆盖Workbook对象变量，打开完成后最后激活的是tech14.xlsx，后续执行筛选、列选择的操作根本没有落在存数据的Suivi.xlsm工作表上，选到的是空列自然没有内容可以复制。
• 循环边界语法错误：For n = 1 To uniquesArray 是非法写法，VBA中循环的终止值必须是数值，遍历数组需要用UBound(uniquesArray)取数组上界，否则循环逻辑根本不会按预期执行。
• 复制逻辑不稳定：全程用Select、Activate切换窗口、选中区域的写法容错性极差，只要窗口焦点意外偏移就会复制到错误的区域；而且直接选整列复制，在筛选状态下不仅效率极低，还会携带大量无效空行。
• 冗余逻辑风险：逐行写14次工作簿关闭代码，一旦某个文件没有成功打开，执行Close时会直接抛出运行时错误，中断整个流程。

Sub TepHebdo()
    Dim i As Long
    Dim n As Long
    Dim wsSource As Worksheet
    Dim lastRow As Long
    Dim copyRng As Range
    Dim techWbs(1 To 14) As Workbook
    
    ' 关闭屏幕更新提升运行速度，避免窗口闪烁
    Application.ScreenUpdating = False
    Application.CutCopyMode = False
    
    ' 显式指定数据源工作表：当前代码所在的Suivi.xlsm内的原始数据表
    ' 请将引号内的内容替换为你实际的工作表名称
    Set wsSource = ThisWorkbook.Worksheets("数据源")
    
    ' 提前关闭可能残留打开的tech文件，避免冲突
    On Error Resume Next
    For i = 1 To 14
        Workbooks("tech" & i & ".xlsx").Close SaveChanges:=False
    Next
    On Error GoTo 0
    
    ' 批量打开目标文件并存储引用，无需后续反复切换窗口查找
    For i = 1 To 14
        Set techWbs(i) = Workbooks.Open("C:\Users\arabw\Desktop\vba\StatTech\tech" & i & ".xlsx")
        ' 清空目标表原有内容，避免旧数据残留，不需要可删除下一行
        techWbs(i).Worksheets(1).Cells.Clear
    Next
    
    ' 清除源表旧筛选，定位数据最后一行
    If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历不重复筛选值，修正原数组循环的语法错误
    ' 请确认uniquesArray已提前赋值为第13列的不重复值列表
    For n = LBound(uniquesArray, 1) To UBound(uniquesArray, 1)
        ' 按当前值筛选第13列
        wsSource.Range("A1:AX" & lastRow).AutoFilter Field:=13, Criteria1:=uniquesArray(n, 1)
        
        ' 仅定位筛选后N:P列的可见单元格，不选整列、不复制隐藏行
        ' 若需要复制表头，将下面代码中的N2改为N1即可
        On Error Resume Next
        Set copyRng = wsSource.Range("N2:P" & lastRow).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ' 存在可见数据时直接复制到对应目标文件，无需切换窗口
        If Not copyRng Is Nothing Then
            copyRng.Copy techWbs(n).Worksheets(1).Range("A1")
            techWbs(n).Save
            Set copyRng = Nothing
        End If
        
        ' 清除当前筛选条件，准备下一轮循环
        wsSource.AutoFilter.ShowAllData
    Next
    
    ' 循环关闭所有目标文件，无需逐行重复写关闭逻辑
    For i = 1 To 14
        techWbs(i).Close SaveChanges:=True
    Next
    
    ' 恢复源表状态与系统设置
    wsSource.AutoFilterMode = False
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    
    MsgBox "数据导出完成！"
End Sub

• 代码中Set wsSource = ThisWorkbook.Worksheets("数据源") 行，需要将引号内的数据源替换为Suivi.xlsm中存储原始数据的工作表实际名称，否则会触发下标越界错误。
• 请提前确认uniquesArray中存储的不重复筛选值顺序与tech1~tech14的文件一一对应，若顺序不匹配，需要新增根据筛选值匹配目标文件名的逻辑，不能直接用循环序号n匹配文件序号，否则会出现数据错粘。
• 禁止在VBA中滥用Select、Activate切换窗口/选中区域的写法，显式声明工作簿、工作表对象直接操作，是避免复制粘贴失效、提升代码稳定性的核心原则。

内容的提问来源于stack exchange，提问作者ⵡⴰⵍⵉⴷ