Copy and Paste Filtered lists - Visible cells only

[fddekker]

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

 

[SyedGangsta]

I didn't pickup on the paste to visible cells.

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

[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]

Try this.

[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]

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:

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:

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

 

[AlphaFrog]

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.

Try this...

[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]

 

[SyedGangsta]

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..

 

[AlphaFrog]

You're welcome and thanks for the feedback.

 

[kenny_devon]

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

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