Excel VBA 筛选可见单元格filldown并复制到新工作表问题求助

原有代码问题排查 #

• 区域定义错误：Range("X3:X")未指定结束行，属于无效的单元格区域声明
• FillDown方法使用错误：该方法仅支持连续单元格区域，筛选后的可见单元格为非连续区域，直接调用会执行失败
• 冗余选中操作过多：大量调用.Select、ActiveCell依赖界面选中状态，执行效率低且容易出现范围偏差
• 复制逻辑混乱：无明确的复制范围定义，多次选中操作逻辑不连贯，无法准确定位到需要复制的内容

修正后可直接运行的代码 #

Sub 筛选填充并复制到新表()
    Dim 源表 As Worksheet, 目标表 As Worksheet
    Dim 最后行号 As Long, 填充区域 As Range, 复制区域 As Range
    
    ' 绑定工作表对象，无需切换界面选中
    Set 源表 = ThisWorkbook.Sheets("Sheet1")
    Set 目标表 = ThisWorkbook.Sheets("Weekday")
    
    ' 清空目标表历史内容，不需要可以删除此行
    目标表.Cells.Clear
    
    With 源表
        ' 先清除已有筛选避免冲突
        If .AutoFilterMode Then .AutoFilter.ShowAllData
        ' 自动获取数据源最后一行行号，不需要写死295行适配数据增减
        最后行号 = .Range("Y" & .Rows.Count).End(xlUp).Row
        ' 按Y列筛选工作日
        .Range("A2:Y" & 最后行号).AutoFilter Field:=25, Criteria1:=Array( _
            "Monday", "Tuesday", "Wednesday", "Thursday", "Friday"), Operator:=xlFilterValues
        
        ' 定位X列需要填充公式的可见单元格
        Set 填充区域 = .Range("X3:X" & 最后行号).SpecialCells(xlCellTypeVisible)
        ' 批量写入公式，非连续区域自动适配无需FillDown
        填充区域.FormulaR1C1 = "=VLOOKUP(RC[-21],'Weekday-Rate'!R3C3:R38C4,2,FALSE)"
        
        ' 定义需要复制的可见区域，默认复制筛选后整行数据，仅需复制X列可替换为Set 复制区域 = 填充区域
        Set 复制区域 = .Range("A2:Y" & 最后行号).SpecialCells(xlCellTypeVisible)
        ' 直接复制到目标表A1位置，无需切换选中
        复制区域.Copy Destination:=目标表.Range("A1")
        
        ' 恢复源表无筛选状态，清空剪切板
        .AutoFilter.ShowAllData
        Application.CutCopyMode = False
    End With
End Sub

自定义调整说明 #

• 若只需要复制X列填充后的公式结果，修改复制区域定义即可
• 若需要粘贴为数值而非公式，将复制语句替换为以下两行：

复制区域.Copy
目标表.Range("A1").PasteSpecial xlPasteValues

• VLOOKUP的匹配范围如果需要固定，可在对应行号列号前添加$符号锁定引用

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