copy visble cells value and then paste into visible cells

[jordanburch]

Hey all

I have the following


Range("h2:h7000").SpecialCells(xlCellTypeVisible).Formula = "=+-RC[-1]"
Range("h2:H7000").SpecialCells(xlCellTypeVisible).Copy
Range("g2:g7000").SpecialCells(xlCellTypeVisible).Paste

its erroring out when I get to the last part for the G range. I just want to copy visible values from H into the visible cells in column g. Any ideas?

runtime error 438 it doesnt support the object is the error message I get. Any help is appreciated.

 

[Akuini]

Hi, @jordanburch

I just want to copy visible values from H into the visible cells in column g.

You can try this code, if it works then you can amend the code to suit.

Run the code > an inputbox will appear > select a range to copy > OK > select only the first cell to paste > OK.

Sub CopyVisibleToVisible1()
'use this for:
'Copy paste(value only):
'from filtered range to filtered range
'from filtered range to unfiltered range
'from unfiltered range to filtered range
'Not work on hidden column

    Dim rngA As Range
    Dim rngB As Range
    Dim r As Range
    Dim Title As String
    Dim ra As Long
    Dim rc As Long
    
    On Error GoTo skip:
    
    Title = "Copy Visible To Visible"
    Set rngA = Application.Selection
    Set rngA = Application.InputBox("Select Range to Copy then click OK:", Title, rngA.Address, Type:=8)
    
    Set rngB = Application.InputBox("Select Range to Paste (select the first cell only):", Title, Type:=8)
    Set rngB = rngB.Cells(1, 1)
    Application.ScreenUpdating = False

    ra = rngA.Rows.Count
    rc = rngA.Columns.Count
    If ra = 1 Then rngB.Resize(, rc).Value = rngA.Value: Exit Sub
    
    Set rngA = rngA.Cells(1, 1).Resize(ra, 1)
    
    For Each r In rngA.SpecialCells(xlCellTypeVisible)
      rngB.Resize(1, rc).Value = r.Resize(1, rc).Value
        Do
          Set rngB = rngB.Offset(1, 0)
        Loop Until rngB.EntireRow.Hidden = False
    Next
    
    Application.GoTo rngB
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
Exit Sub
skip:
    If err.Number <> 424 Then
        MsgBox "Error found: " & err.Description
    End If
    
    Application.ScreenUpdating = True
    Application.CutCopyMode = False

End Sub