How to paste as values with VBA after Autofiltering and using .End

Question

I am using the following code to autofilter the data on one sheet and paste specific columns onto another sheet. The issue I have is that the data on the wsData sheet in columns AG and AJ is formula, but I need it to be pasted as values. How do I amend this code to do this?

With wsData.Rows(1)
.AutoFilter field:=30, Criteria1:="In Progress - On Order"
If wsData.Range("AC1:C" & lastrow).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
    wsData.Range("N2:N" & lastrow).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A" & Rows.Count).End(3)(2)
    wsData.Range("C2:C" & lastrow).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("B" & Rows.Count).End(3)(2)
    wsData.Range("Q2:Q" & lastrow).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("F" & Rows.Count).End(3)(2)
    wsData.Range("R2:R" & lastrow).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("G" & Rows.Count).End(3)(2)
    wsData.Range("S2:S" & lastrow).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("H" & Rows.Count).End(3)(2)
    wsData.Range("T2:T" & lastrow).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("I" & Rows.Count).End(3)(2)
    wsData.Range("AG2:AG" & lastrow).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("C" & Rows.Count).End(3)(2)
    wsData.Range("AJ2:AJ" & lastrow).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("M" & Rows.Count).End(3)(2)
    
    
    wsDest.UsedRange.Borders.ColorIndex = xlNone
    wsDest.Select
End If
.AutoFilter field:=30

End with

Many thanks,

FaneDuru · Answer 1 · 2021-04-15T12:33:28.467

Please, replace:

wsData.Range("AG2:AG" & lastrow).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("C" & Rows.Count).End(3)(2)
wsData.Range("AJ2:AJ" & lastrow).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("M" & Rows.Count).End(3)(2)

with:

wsData.Range("AG2:AG" & lastrow).SpecialCells(xlCellTypeVisible).Copy
   wsDest.Range("C" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
wsData.Range("AJ2:AJ" & lastrow).SpecialCells(xlCellTypeVisible).Copy 
   wsDest.Range("M" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues

You can make the code faster and consuming less resources, if format is not needed, by not involving the clipboard (using arrays, but using a function to transform the discontinuous range in a continuous one...).

In fact, try the next adapted code, please:

Sub ArrayVariant()
'your existing code
 Dim arr
 If wsData.Range("AC1:C" & lastRow).SpecialCells(xlCellTypeVisible).cells.count > 1 Then
    arr = contArrayFromDscRng(wsData.Range("N2:N" & lastRow).SpecialCells(xlCellTypeVisible))
        wsDest.Range("A" & rows.count).End(3)(2).Resize(UBound(arr), UBound(arr, 2)).value = arr
    arr = contArrayFromDscRng(wsData.Range("C2:C" & lastRow).SpecialCells(xlCellTypeVisible))
        wsDest.Range("B" & rows.count).End(3)(2).Resize(UBound(arr), UBound(arr, 2)).value = arr
    arr = contArrayFromDscRng(wsData.Range("Q2:Q" & lastRow).SpecialCells(xlCellTypeVisible))
        wsDest.Range("F" & rows.count).End(3)(2).Resize(UBound(arr), UBound(arr, 2)).value = arr
    arr = contArrayFromDscRng(wsData.Range("R2:R" & lastRow).SpecialCells(xlCellTypeVisible))
        wsDest.Range("G" & rows.count).End(3)(2).Resize(UBound(arr), UBound(arr, 2)).value = arr
    arr = contArrayFromDscRng(wsData.Range("S2:S" & lastRow).SpecialCells(xlCellTypeVisible))
        wsDest.Range("H" & rows.count).End(3)(2).Resize(UBound(arr), UBound(arr, 2)).value = arr
    arr = contArrayFromDscRng(wsData.Range("T2:T" & lastRow).SpecialCells(xlCellTypeVisible))
        wsDest.Range("I" & rows.count).End(3)(2).Resize(UBound(arr), UBound(arr, 2)).value = arr
    arr = contArrayFromDscRng(wsData.Range("AG2:AG" & lastRow).SpecialCells(xlCellTypeVisible))
        wsDest.Range("C" & rows.count).End(3)(2).Resize(UBound(arr), UBound(arr, 2)).value = arr
    arr = contArrayFromDscRng(wsData.Range("AJ2:AJ" & lastRow).SpecialCells(xlCellTypeVisible))
        wsDest.Range("M" & rows.count).End(3)(2).Resize(UBound(arr), UBound(arr, 2)).value = arr
    
    wsDest.UsedRange.Borders.ColorIndex = xlNone
    wsDest.Activate
 End If
 'your existing code...
End Sub

Function contArrayFromDscRng(rng As Range) As Variant 'makes an array from a discontinuous range
    Dim A As Range, arr, count As Long, i As Long
    
    ReDim arr(1 To rng.cells.count, 1 To 1): count = 1
    For Each A In rng.Areas
            For i = 1 To A.cells.count
                arr(count, 1) = A.cells(i).value: count = count + 1
            Next
    Next
    contArrayFromDscRng = arr
End Function

How to paste as values with VBA after Autofiltering and using .End

1 Answers1