Excel VBA仅将可见过滤值从一列复制粘贴到另一列

Question

我正在尝试复制粘贴 仅限 从“B”列到“Y”列的可见过滤(日期)值。 (在过滤条件下，我只能将“B”列的一小部分复制到“Y”。)

我试图在下面的宏的帮助下做到这一点。不幸的是，这不起作用，因为它将“B”列中的所有内容(也是未过滤的值)复制到“Y”，我想将未过滤的数据保留在“Y”中

x = 4
Do While Cells(x, 1).Value <> ""
Cells(x, 25).Value = Cells(x, 2).Value
x = x + 1
Loop 

我也尝试了像下面这样的变体，但这些副本也只是 B 列的一部分，否则代码会引发错误。

Range(Cells(4, 2), Cells(Range("B" & Rows.Count).End(xlDown).Row, 2)).SpecialCells(xlCellTypeVisible).Copy
ActiveSheet.Range (Cells(4, 25).PasteSpecial(xlPasteAll)) ' Range("Y4").PasteSpecial(xlPasteAll)) 

有谁知道我该如何解决这个问题？谢谢你。

Answer 1

将过滤后的数据复制到另一列

Option Explicit

Sub CopyToY()
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
    
    ' First Cell of the Data Range (in the row below headers)
    Dim fCell As Range: Set fCell = ws.Range("B4")
    ' Last Cell of the Filtered Range
    Dim lCell As Range: Set lCell = ws.Range("B" & ws.Rows.Count).End(xlUp)
    ' If no filtered data, the last cell will be the header cell, which
    ' is above the first cell. Check this with:
    If lCell.Row < fCell.Row Then Exit Sub ' no filtered data
    
    ' Range from First Cell to Last Cell
    Dim rg As Range: Set rg = ws.Range(fCell, lCell)
    
    ' Filtered Data Range
    Dim frg As Range: Set frg = rg.SpecialCells(xlCellTypeVisible)
    
    ' Area Range
    Dim arg As Range
    
    For Each arg In frg.Areas
        ' Either copy values (more efficient (faster))...
        arg.EntireRow.Columns("Y").Value = arg.Value
        ' ... or copy values, formulas and formatting
        'arg.Copy arg.EntireRow.Columns("Y")
    Next arg
    
    MsgBox "Filtered data copied to column ""Y"".", vbInformation
    
End Sub