Copying visible data from one filtered column to another in the same sheet as values-CodePudding

I am having trouble copying visible cells from a filtered data column (T) to another column (Q) in the same sheet. I have tried this method, but the data I am working with is over 100,000 columns and going line by line is taking forever. Another option I have explored is to manually change the formula for Q to =T but I don't know how to implement this into VBA as I am new to it.

Option Explicit
Sub Test1()


Dim ws As Worksheet: Set ws = ActiveSheet


ws.Range("$A$1", ActiveCell.SpecialCells(xlLastCell)).AutoFilter Field:=19, Criteria1:= _
    "=NMCM", Operator:=xlOr, Criteria2:="=Houses"
ws.Range("$A$1", ActiveCell.SpecialCells(xlLastCell)).AutoFilter Field:=20, Criteria1:=Array _
    ("Test1", "Test2"), _
    Operator:=xlFilterValues

' First Cell of the Data Range (in the row below headers)
Dim fCell As Range: Set fCell = ws.Range("T2")
' Last Cell of the Filtered Range
Dim lCell As Range: Set lCell = ws.Range("T" & 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("Q").Value = arg.Value
    ' ... or copy values, formulas and formatting
    'arg.Copy arg.EntireRow.Columns("Y")
Next arg

End Sub

CodePudding user response：

Write Filtered Column to Another Filtered Column

Option Explicit

Sub Extract_Airworthy_status()
    
    Const sfCol As Long = 19 ' S
    Const sCol As Long = 20 ' T
    Const dCol As Long = 17 ' Q
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Dim sdrg As Range ' Source Data Range (no headers)
    With ws.Range("A1").CurrentRegion
        Set sdrg = .Columns(sCol).Resize(.Rows.Count - 1).Offset(1)
        .AutoFilter Field:=sfCol, Criteria1:="=NMCM", _
            Operator:=xlOr, Criteria2:="=Houses"
        .AutoFilter Field:=sCol, Criteria1:=Array("Test1", "Test2"), _
            Operator:=xlFilterValues
    End With
    
    Dim sdfrg As Range ' Source Data Filtered Range
    On Error Resume Next
        Set sdfrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ws.AutoFilterMode = False
    If sdfrg Is Nothing Then Exit Sub
    
    Dim cOffset As Long: cOffset = dCol - sCol
    
    Dim ddfrg As Range ' Destination Data Filtered Range
    Set ddfrg = sdfrg.Offset(, cOffset)
    ddfrg.Formula = "=" & sdfrg.Cells(1).Address(0, 0)
    
    Dim ddrg As Range ' Destination Data Range
    Set ddrg = sdrg.Offset(, cOffset)
    ddrg.Value = ddrg.Value
    
End Sub