Search code examples
excelvbacopyvisibleautofilter

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


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

Solution

  • 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