Copy and Paste Filtered lists - Visible cells only

F

fddekker

Board Regular
Joined
Jun 30, 2008
Messages
86
Office Version
  1. 365
Platform
  1. Windows
I maintain an add-in with handy macros that we use at work. I would like to add one for copy and pasting filtered lists on the same sheet, e.g. a filtered list in a2:c9 should be copied to g2:i9. Only visible cells should be copied.
I know this can be accomplished by:
1: selecting the ‘paste-to’ range (e.g. g2:i9),
2: clicking on the visible cells only icon (added to the toolbar),
3: typing an equal sign in the top left cell of the area (e.g. g2)
4: navigating to the top left cell of ‘copy-from’ area (e.g. a2) and
5: hit ctrl-enter
to fill the original area

... however, explaining this to new Excel users over the phone is NOT the easiest thing. I would like the add-in to have a button on the ribbon, that when clicked, will only require the user to select the two ranges and the copying and pasting should be handled by vba. What would be the most effective way of accomplishing this?


Thanks in advance!

Francois
 
Sort by date Sort by votes
AlphaFrog said:
I didn't pickup on the paste to visible cells.

Try this. It only test for hidden rows (not columns).

Code: 
[COLOR=darkblue]Sub[/COLOR] Copy_Paste_Filtered_Cells()
    
    [COLOR=darkblue]Dim[/COLOR] rngSource [COLOR=darkblue]As[/COLOR] Range, rngDestination [COLOR=darkblue]As[/COLOR] Range, cell [COLOR=darkblue]As[/COLOR] Range, cc [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR], i [COLOR=darkblue]As[/COLOR] Long
    
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
    Application.DisplayAlerts = [COLOR=darkblue]False[/COLOR]
    
    [COLOR=darkblue]Set[/COLOR] rngSource = Application.InputBox("Select the filtered range to copy. ", "Select Filtered Cells", Type:=8)
    [COLOR=darkblue]If[/COLOR] rngSource [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR] Application.DisplayAlerts = True: [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]   [COLOR=green]'User canceled[/COLOR]
    
    [COLOR=darkblue]Set[/COLOR] rngDestination = Application.InputBox("Select the destination cell to paste to. ", "Select Paste Destination", Type:=8)
    [COLOR=darkblue]If[/COLOR] rngDestination [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR] Application.DisplayAlerts = True: [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]  [COLOR=green]'User canceled[/COLOR]
    
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
    Application.DisplayAlerts = [COLOR=darkblue]True[/COLOR]
    
    cc = rngSource.Columns.Count
    
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] rngSource.Columns(1).SpecialCells(xlCellTypeVisible)
        [COLOR=darkblue]Do[/COLOR]
            i = i + 1
        [COLOR=darkblue]Loop[/COLOR] [COLOR=darkblue]Until[/COLOR] [COLOR=darkblue]Not[/COLOR] rngDestination(1).Offset(i).EntireRow.Hidden
        rngDestination(1).Offset(i).Resize(1, cc).Value = cell.Resize(1, cc).Value
    [COLOR=darkblue]Next[/COLOR]
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
Click to expand...


AlphaFrog said:
Try this.

Code: 
[COLOR=darkblue]Sub[/COLOR] Copy_Paste_Filtered_Cells()
    
    [COLOR=darkblue]Dim[/COLOR] rngSource [COLOR=darkblue]As[/COLOR] Range, rngDestination [COLOR=darkblue]As[/COLOR] Range, cell [COLOR=darkblue]As[/COLOR] Range, cc [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR], i [COLOR=darkblue]As[/COLOR] Long
    
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
    Application.DisplayAlerts = [COLOR=darkblue]False[/COLOR]
    
    [COLOR=darkblue]Set[/COLOR] rngSource = Application.InputBox("Select the filtered range to copy. ", "Select Filtered Cells", Type:=8)
    [COLOR=darkblue]If[/COLOR] rngSource [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR] Application.DisplayAlerts = True: [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]   [COLOR=green]'User canceled[/COLOR]
    
    [COLOR=darkblue]Set[/COLOR] rngDestination = Application.InputBox("Select the destination cell to paste to. ", "Select Paste Destination", Type:=8)
    [COLOR=darkblue]If[/COLOR] rngDestination [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR] Application.DisplayAlerts = True: [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]  [COLOR=green]'User canceled[/COLOR]
    
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
    Application.DisplayAlerts = [COLOR=darkblue]True[/COLOR]
    
    cc = rngSource.Columns.Count
    
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] rngSource.Columns(1).SpecialCells(xlCellTypeVisible)
        [COLOR=darkblue]Do[/COLOR] [COLOR=darkblue]Until[/COLOR] [COLOR=darkblue]Not[/COLOR] rngDestination(1).Offset(i).EntireRow.Hidden
            i = i + 1
        [COLOR=darkblue]Loop[/COLOR]
        rngDestination(1).Offset(i).Resize(1, cc).Value = cell.Resize(1, cc).Value
        i = i + 1
    [COLOR=darkblue]Next[/COLOR]
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
Click to expand...

Hi Just wanted to thank you for the code above which seems to work as desired, I tried many methods, and was releived to find one that got me moving forward.

I do however have query, I know I should be able to solve it myself, but my mind has gone blank (or you could call it lazy!)

First of all I changed you solution to remove the user input side, so its all done in code on a selected range of data, also I found that I needed to clear the previous data, the code runs constantly as changes are applied to filter criteria which is set from combo boxes and text boxes.

The problem I have is that if the filter results in Nil data (i.e. filter eliminates all data) I the code halts with a error message.

please see your modified code below:

Code: 
Sub CopyVisiblRowsOnly() 'the one that seems to do the job
Dim rngSource As Range, rngDestination As Range, cell As Range, cc As Long, i As Long


 Sheets("DynamicRanges").Range("A2:AR1133").ClearFormats
 Sheets("DynamicRanges").Range("A2:AR1133").ClearContents
    
    On Error Resume Next
    Application.DisplayAlerts = False
    
    Set rngSource = Application.Range("filterrange")
    
    If rngSource Is Nothing Then Exit Sub   'User canceled
    
    Set rngDestination = Worksheets("DynamicRanges").Range("A2")
    If rngDestination Is Nothing Then Application.DisplayAlerts = True: Exit Sub  'User canceled
    
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    cc = rngSource.Columns.Count
    
    For Each cell In rngSource.Columns(1).SpecialCells(xlCellTypeVisible)
        Do Until Not rngDestination(1).Offset(i).EntireRow.Hidden
            i = i + 1
        Loop
        rngDestination(1).Offset(i).Resize(1, cc).Value = cell.Resize(1, cc).Value
        i = i + 1
    Next
End Sub



Its called from combobox/textbox on change event such as the one below:

Code: 
Private Sub TBOrganisation_Change()
If TBOrganisation.Value = "" Then
Selection.AutoFilter Field:=9
Else
    Selection.AutoFilter Field:=9, Criteria1:="=" & "*" & TBOrganisation.Value & "*", Operator:=xlAnd
End If
CopyVisiblRowsOnly
End Sub


I am copying visible rows from range name 'FilterRange' located on a sheet named 'Database' to cell A2 on sheet named 'Dynamic Ranges'.


If all goes well (quite some thing in vba) then I also want to pull rows with unique data also... but that is another matter.

Many thanks for any assistance. ;)


gangsta
 
Upvote 0

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
SyedGangsta said:
The problem I have is that if the filter results in Nil data (i.e. filter eliminates all data) I the code halts with a error message.
Click to expand...

Try this...

Code: 
[COLOR=darkblue]Sub[/COLOR] CopyVisiblRowsOnly() [COLOR=green]'the one that seems to do the job[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] rngSource [COLOR=darkblue]As[/COLOR] Range, rngDestination [COLOR=darkblue]As[/COLOR] Range, cell [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] cc [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR], i [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR], VisibleCellCount [COLOR=darkblue]As[/COLOR] Long
    
    Sheets("DynamicRanges").Range("A2:AR1133").ClearFormats
    Sheets("DynamicRanges").Range("A2:AR1133").ClearContents
    
    [COLOR=darkblue]Set[/COLOR] rngSource = Application.Range("filterrange")
    [COLOR=darkblue]Set[/COLOR] rngDestination = Worksheets("DynamicRanges").Range("A2")
    cc = rngSource.Columns.Count
    
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
        VisibleCellCount = rngSource.SpecialCells(xlCellTypeVisible).Count
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
    [COLOR=darkblue]If[/COLOR] VisibleCellCount = 0 [COLOR=darkblue]Then[/COLOR] [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
        
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] rngSource.Columns(1).SpecialCells(xlCellTypeVisible)
        [COLOR=darkblue]Do[/COLOR] [COLOR=darkblue]Until[/COLOR] [COLOR=darkblue]Not[/COLOR] rngDestination(1).Offset(i).EntireRow.Hidden
            i = i + 1
        [COLOR=darkblue]Loop[/COLOR]
        rngDestination(1).Offset(i).Resize(1, cc).Value = cell.Resize(1, cc).Value
        i = i + 1
    [COLOR=darkblue]Next[/COLOR]
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
 
Upvote 0
AlphaFrog, your solution worked a treat and really made my day, many many thanks. The forum is a great place when there are people like yourself in the community.

I promise I'll make a note to self and share my solutions with everybody just so that the ball keeps rolling..:)
 
Upvote 0
Hi guys

First post - so let me know if I've done anything wrong!

This is a variation on the code provided above that should work with hidden rows and columns, in both the source and the destination
It makes use of a single named cell in the workbook that stores the address of the source data.
It is intended for copying a block of cells to a similar block of cells where the destination is specified by selecting a single cell
The macro should be given a ctrl key shortcut - I used Ctrl-Shft-C

First select the source block
Press the Ctrl key shortcut
Your selection is stored
Select the (single) destination cell
Press the same Ctrl key shortcut again
The data is pasted respecting the visibility of the rows and columns of the source and destination areas

Code: 
Sub copyVisible()
    
    Dim rngSource, rngDestination, cell, rowcell, rowcells As Range
    Dim cc, i, j As Long
    Dim lCopy As Boolean
    i = 0
    
    lCopy = Selection.Rows.Count * Selection.Columns.Count > 1
    If lCopy Then
        Range("rngSource") = Selection.Address
    Else
        Set rngSource = Range(Range("rngSource"))
        Set rngDestination = Selection
        
        cc = rngSource.Columns.Count
        
        ' ignore any invisible rows in the source
        For Each cell In rngSource.Columns(1).SpecialCells(xlCellTypeVisible)
            ' find the next visible row in the destination
            Do Until Not rngDestination(1).Offset(i).EntireRow.Hidden
                i = i + 1
            Loop
            
            ' loop through the visible columns in the source data
            Set rowcells = cell.Resize(1, cc)
            j = 0
            For Each rowcell In rowcells.SpecialCells(xlCellTypeVisible)
            
                'find next visible column in the destination
                Do Until Not rngDestination(1).Offset(0, j).EntireColumn.Hidden
                    j = j + 1
                Loop
                
                rngDestination(1).Offset(i, j).Value = rowcell.Value
                j = j + 1
            Next rowcell
            i = i + 1
        Next
    End If
End Sub

Hope this helps

Kenny
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Search/Filter a Spreadsheet by User Entered Value
Replies
3
Views
117
jbennett01
J
T
  • Question Question
Multiple filters on filtered list
Replies
1
Views
603
Cubist
Cubist
J
  • Question Question
Filtering Results in List Box
Replies
2
Views
115
JohnS_323
J
N
  • Question Question
Excel VBA copy data to a worksheet in list form
Replies
0
Views
82
NewbieExcel123
N
M
  • Question Question
Creating and emailing Excel sheet with only visible data
Replies
0
Views
499
mecerrato
M

Forum statistics

Threads
1,223,632
Messages
6,173,472
Members
452,516
Latest member
archcalx

Share this page

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