PDA

View Full Version : [SOLVED] Copy Paste to visible cells only with different sheets / workbooks



Ehcacommence
09-03-2017, 02:23 AM
Hi everyone !

Thanks to anyone affording time to read this and possibly help :)

Here is my issue :
I'd like to copy data from a filtered column, then paste it to a filtered column in a different sheet, or even a different workbook.
I have a macro that works perfectly well to do that in single sheet. But excel crashes if I try to use it to paste in a different sheet or workbook.

Any idea of a way around ?

To enlighten my issue, I here enclose a file :
The column "Count 1" in Sheet 1 is filtered so that blank cells aren't visible.
I'd like to copy those visible cells and paste them in the column "Count 1" of the sheet 2. Given that, in sheet 2, I have a column "Count 2" that is filtered as well.
Again, any solution working for different sheets would be awesome, but any solution solution working for different workbooks would be even better ! :)

Here the code I use that only works in a single sheet :


Sub Copy_Paste_Visible_Cells_Only()
Dim rngtocopy As Range
Dim rngtopasteto As Range
Dim cell As Range
Dim ccount As Long
Dim i As Long
On Error Resume Next
Application.DisplayAlerts = False
Set rngtocopy = Application.InputBox("Select the filtered range to copy !", "Select Filtered Cells", Type:=8)
If rngtocopy Is Nothing Then Application.DisplayAlerts = True: Exit Sub
Set rngtopasteto = Application.InputBox("Select the destination cell to paste to !", "Select Paste Destination", Type:=8)
If rngtopasteto Is Nothing Then Application.DisplayAlers = True: Exit Sub
On Error GoTo 0
Application.DisplayAlerts = True
ccount = rngtocopy.Columns.Count
For Each cell In rngtocopy.Columns(1).SpecialCells(xlCellTypeVisible)
Do
i = i + 1
Loop Until Not rngtopasteto(1).Offset(i).EntireRow.Hidden
rngtopasteto(1).Offset(i).Resize(1, ccount).Value = cell.Resize(1, ccount).Value
Next
End Sub



Thanks again for your time !

mdmackillop
09-03-2017, 09:23 AM
Sub Test()
Dim i&
Dim arr()
With Sheets(1)
Set a = Intersect(.UsedRange, .Columns(1).SpecialCells(xlCellTypeVisible))
End With
With Sheets(2)
Set b = Intersect(.UsedRange, .Columns(1).SpecialCells(xlCellTypeVisible))
End With


ReDim arr(a.Count)
i = 1
For Each cel In a.Cells
arr(i) = cel.Value
i = i + 1
Next
i = 1
For Each cel In b.Cells
cel.Value = arr(i)
i = i + 1
Next
End Sub

Ehcacommence
09-03-2017, 03:08 PM
Sub Test()
Dim i&
Dim arr()
With Sheets(1)
Set a = Intersect(.UsedRange, .Columns(1).SpecialCells(xlCellTypeVisible))
End With
With Sheets(2)
Set b = Intersect(.UsedRange, .Columns(1).SpecialCells(xlCellTypeVisible))
End With


ReDim arr(a.Count)
i = 1
For Each cel In a.Cells
arr(i) = cel.Value
i = i + 1
Next
i = 1
For Each cel In b.Cells
cel.Value = arr(i)
i = i + 1
Next
End Sub


Hi,

I guess I'll thank you for your answer, also I have no idea what the hell I'm suposed to do with it haha !

I did try to understand your code. Then I tried it.

But well, can't say it got me anywhere really ! Do I miss the point ?

Thanks for your time !

mdmackillop
09-04-2017, 12:07 AM
Copy error, Change 1 to 4 in this line

Set b = Intersect(.UsedRange, .Columns(4).SpecialCells(xlCellTypeVisible))