Search code examples
excelvbaexcel-2010

Copy and Paste with Specialcells

Any idea of why my code gets run-time- error '1004' Application-defined of object defined error?

I'm on my way to copy and paste data on a visible cell only. But I got stuck started from this line:

It get stuck at the

Sheets(targetSheet).Range("E2" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial

Function GetTheLastRow(sheetName As String) As Long
    'Function untuk mendapatkan row terakhir dalam sheet
    Dim sheetTarget As Worksheet
    Dim lastRow As Integer
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Set sheetTarget = wb.Sheets("Existing")
    lastRow = sheetTarget.Cells(sheetTarget.Rows.Count, 1).End(xlUp).Row
    GetTheLastRow = lastRow
End Function

Sub CopyVisibleOnly()
    ' Sub untuk melakukan copy only visible value
    Dim sourceSheet As String, targetSheet As String
    Dim lastRowSourceSheet As Long
    
    Set wb = ThisWorkbook
    sourceSheet = "Existing"
    targetSheet = "TTD"
    
    lastRowSourceSheet = GetTheLastRow(sourceSheet)
    
    Sheets(sourceSheet).Range("A2:AG" & lastRowSourceSheet).AutoFilter field:=12, Criteria1:="<>"
    Sheets(sourceSheet).Range("A2:AG" & lastRowSourceSheet).AutoFilter field:=13, Criteria1:="<>"
    
    Sheets(sourceSheet).Range("A2:A" & lastRowSourceSheet).SpecialCells(xlCellTypeVisible).Copy
    Sheets(targetSheet).Range("E2" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    
    Sheets(sourceSheet).Range("B2:B" & lastRowSourceSheet).SpecialCells(xlCellTypeVisible).Copy
    Sheets(targetSheet).Range("F2" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    
    Sheets(sourceSheet).Range("F2:F" & lastRowSourceSheet).SpecialCells(xlCellTypeVisible).Copy
    Sheets(targetSheet).Range("G2" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    
    Sheets(sourceSheet).Range("N2:N" & lastRowSourceSheet).SpecialCells(xlCellTypeVisible).Copy
    Sheets(targetSheet).Range("H2" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    
    Sheets(sourceSheet).Range("P2:P" & lastRowSourceSheet).SpecialCells(xlCellTypeVisible).Copy
    Sheets(targetSheet).Range("I2" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    
    Sheets(sourceSheet).Range("Q2:Q" & lastRowSourceSheet).SpecialCells(xlCellTypeVisible).Copy
    Sheets(targetSheet).Range("J2" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
    
    Sheets(sourceSheet).Range("O2:O" & lastRowSourceSheet).SpecialCells(xlCellTypeVisible).Copy
    Sheets(targetSheet).Range("K2" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End Sub
Solution

  • Copy Filtered Data

    enter image description here enter image description here

    Option Explicit

Sub CopyFilteredData()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Existing")
    sws.AutoFilterMode = False
    Dim slRow As Long: slRow = GetLastRow(sws)
    Dim scrg As Range: Set scrg = sws.Range("A:A,B:B,F:F,N:N,P:P,Q:Q,O:O")
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Sheets("TTD")
    Dim dlRow As Long: dlRow = GetLastRow(dws, "E")
    Dim dcell As Range: Set dcell = dws.Cells(dlRow + 1, "E")
    
    ' Filter.
    
    Dim sdrg As Range ' data range (no headers)
    With sws.Range("A1", sws.Cells(slRow, "AG")) ' has headers
        Set sdrg = .Resize(.Rows.Count - 1).Offset(1)
        .AutoFilter Field:=12, Criteria1:="<>"
        .AutoFilter Field:=13, Criteria1:="<>"
    End With
    
    Dim svrg As Range ' visible data range
    On Error Resume Next
        Set svrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    sws.AutoFilterMode = False
    
    If svrg Is Nothing Then
        MsgBox "No filtered values found.", vbExclamation
        Exit Sub
    End If
       
    ' Copy.
    Dim sarg As Range
    With svrg.EntireRow
        For Each sarg In scrg.Areas
            Intersect(.Cells, sarg).Copy Destination:=dcell
            Set dcell = dcell.Offset(, sarg.Columns.Count)
        Next sarg
    End With
    
    ' Inform.
    MsgBox "Filtered data copied.", vbInformation
    
End Sub

Function GetLastRow( _
    ws As Worksheet, _
    Optional LastRowColumn As Variant = "A") _
As Long
    GetLastRow = ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Row
End Function