• If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.
  • Excel articles and downloadable files provided in the articles have not been reviewed by MrExcel Publishing. Please apply the provided methods / codes and open the files at your own risk. If you have any questions regarding an article, please use the Article Discussion section.
Akuini

Excel VBA: easy way to paste to visible cells

Excel Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
  5. 2013
  6. 2011
  7. 2010
  8. 2007
Excel does not provide a direct method for copying and pasting from visible cells to visible cells.
So here's a method using VBA:

How it works:
1. Put the "Sub CopyVisibleToVisible1" code in a code module.
2. Run the code.
3. An input box will appear, asking you to select the range you want to copy. Select the range as required and click "OK."
paste1.jpg


4. Another input box will appear, asking you to select the range where you want to paste. Select only the first cell and click "OK."
paste2.jpg


5. Result:
paste3.jpg


The code:
VBA Code:
Sub CopyVisibleToVisible1()
'Use this for:
'Copy-paste(values 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


If you plan to use this frequently in any open workbook, you can put the code in PERSONAL.xlsb and assign a toolbar button to it. Here's how:

1. Open the VBA window by pressing ALT+F11.
2. Open PERSONAL.xlsb.
3. In the module section, create a new module (e.g., Module1).
4. Paste the code into Module1.
5. Now, assign the code to a toolbar button. If you're not sure how to do this, you can follow the instructions on this link: add-macro-buttons-excel-ribbon-toolbar
6. Don't forget to save the VBAPROJECT (PERSONAL.XLSB).

Copy visible.jpg

The benefit of doing it this way:
  • The macro is accessible in any open workbook and is easy to access, i.e. through a ribbon button. So, it feels like a native Excel feature.
  • You don’t need to put the macro on all your workbooks, just on PERSONAL.xlsb.
copy visible 2.jpg


Update: 2024-May-07
I've changed "Sub CopyVisibleToVisible1" to "Sub CopyVisibleToVisible2".
This new version includes two enhancements:
  1. Users can now select a single cell value and paste it into multiple cells within a filtered range.
  2. The code is faster now as it loops through 'Areas' instead of 'Cells' when the copy-range and paste-range have the same structure of visible cells. This is particularly beneficial for large datasets.

Here's the code:
VBA Code:
Sub CopyVisibleToVisible2()
'Author: Akuini, Indonesia, 2024-May-06
'Use this for:
'Copy-paste(values only):
'from filtered range to filtered range
'from filtered range to unfiltered range
'from unfiltered range to filtered range
'Not work on hidden column

'This new version includes two enhancements:
'    1. Users can now select a single cell value and paste it into multiple cells within a filtered range.
'    2. The code is faster now as it loops through 'Areas' instead of 'Cells' when the copy-range and paste-range have the same structure of visible cells.
'       This is particularly beneficial for large datasets.

    Dim rngA As Range
    Dim rngB As Range, rngBB As Range
    Dim r As Range
    Dim Title As String, txA As String, txB As String
    Dim ra As Long, i As Long
    Dim rc As Long, xCol As Long, a1 As Long, a2 As Long, h As Long
    Dim Flag As Boolean
    
    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)
    
    'if copy-range is a single cell and needs to be pasted into multiple cells (in filtered range)
    If rngA.Cells.CountLarge = 1 Then
        Set rngB = Application.InputBox("Select Range (multiple cells) to Paste:", Title, Type:=8)
        rngB.SpecialCells(xlCellTypeVisible).Value = rngA.Value
        Exit Sub
    End If

    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
   
    If Not Intersect(rngA.Cells(1).EntireRow, rngB) Is Nothing Then 'if the copied range is pasted into the same row in the same sheet
                                                                   'therefore the code can loop each visible areas, which is faster than looping each cell.
        xCol = rngB.Column
        For Each r In rngA.SpecialCells(xlCellTypeVisible).Areas
              ActiveSheet.Cells(r.Row, xCol).Resize(r.Rows.Count, r.Columns.Count).Value = r.Value
        Next
        
    Else    'if the copied range is not pasted into the same row then
            'check if copy-range & paste-range has the same structure of visible cells
        
        Set rngB = rngB.Resize(ra, rc)
        a1 = rngA.Columns(1).SpecialCells(xlCellTypeVisible).Areas.Count
        a2 = rngB.Columns(1).SpecialCells(xlCellTypeVisible).Areas.Count
        
        If a1 = a2 Then
            For h = 1 To a1
                'If any corresponding area in both ranges has a different number of rows, it means they have a different structure of visible cells.
                If rngA.Columns(1).SpecialCells(xlCellTypeVisible).Areas(h).Cells.CountLarge <> rngB.Columns(1).SpecialCells(xlCellTypeVisible).Areas(h).Cells.CountLarge Then
                    Flag = True
                    Exit For
                End If
            Next
        Else
            Flag = True
        End If

        
        If Flag = True Then 'if copy-range & paste-range have different structure of visible cells, then the code needs to loop through each cells in both range
                            'this would slow down the process on large data
             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
         Else   'If the copy-range and paste-range have the same structure of visible cells, then the code can loop through each visible area
                'This will speed up the process.
            For i = 1 To rngA.Columns(1).SpecialCells(xlCellTypeVisible).Areas.Count
                rngB.SpecialCells(xlCellTypeVisible).Areas(i).Value = rngA.SpecialCells(xlCellTypeVisible).Areas(i).Value
            Next
        End If

    End If
    
    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

Regards,

Akuini
Author
Akuini
Views
1,699
First release
Last update
Rating
0.00 star(s) 0 ratings

More Excel articles from Akuini

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top