Copy to Visible Cells only;Modify Code

[Abdul]

The following code helps to copy to Visible Cells Only.

What I need is to select any one of the open workbook using a
combobox and select a range (visible Cells Only) using Refedit and
copy the data and through same combobox and Refedit or another
combobox and Refedit select the destination workbook and cell and
paste the copied data to the visible cells only.

Any Help Please....


Option Explicit
Public StartWB As Workbook
Public StartWS As Worksheet
Public CopyRng As String

Public Sub CopyToVisibleOnly1()
'Start with cell selected that you want to copy.
Set StartWB = ActiveWorkbook
Set StartWS = ActiveSheet
CopyRng = Selection.Address
'Call CopyToVisibleOnly2 after a five-second delay.
Application.OnTime Now() + TimeValue("0:00:04"), "CopyToVisibleOnly2"
End Sub

Private Sub CopyToVisibleOnly2()
'Declare local variables.
Dim EndWB As Workbook, EndWS As Worksheet
Dim Target As Range, CurrCell As Range
Dim x As Long, FromCnt As Long
On Error GoTo CTVOerr
'Select the range where it should be pasted.
Set Target = Application.InputBox _
(Prompt:="Select the first cell in the Paste range", Type:=8)
Set EndWB = ActiveWorkbook
Set EndWS = ActiveSheet
Set CurrCell = Target.Cells(1, 1)
Application.ScreenUpdating = False
'Copy the cells from the original workbook, one at a time.
StartWB.Activate
StartWS.Activate
For x = 1 To Range(CopyRng).Count
StartWB.Activate
StartWS.Activate
Range(CopyRng).Cells(x, 1).Copy
'Return to the target workbook.
EndWB.Activate
EndWS.Activate
CurrCell.Activate
'Only cells in visible rows in the selected
'range are pasted.
Do While (CurrCell.EntireRow.Hidden = True) Or _
(CurrCell.EntireColumn.Hidden = True)
Set CurrCell = CurrCell.Offset(1, 0)
Loop
CurrCell.Select
ActiveSheet.Paste
Set CurrCell = CurrCell.Offset(1, 0)
Next x
Cleanup:
'Free the object variables.
Set Target = Nothing
Set CurrCell = Nothing
Set StartWB = Nothing
Set StartWS = Nothing
Set EndWB = Nothing
Set EndWS = Nothing
Application.ScreenUpdating = True
Exit Sub
CTVOerr:
MsgBox Err.Description
GoTo Cleanup
End Sub

 

[Joel]

try this

Option Explicit
Public StartWS As Worksheet
Public CopyRng As Range

Public Sub CopyToVisibleOnly1()

'Start with cell selected that you want to copy.
Set StartWS = ActiveSheet
Set CopyRng = Selection
'Call CopyToVisibleOnly2 after a five-second delay.
Application.OnTime Now() + TimeValue("0:00:04"), _
"CopyToVisibleOnly2"
End Sub

Private Sub CopyToVisibleOnly2()
'Declare local variables.
Dim EndWB As Workbook, EndWS As Worksheet
Dim Target As Range, CurrCell As Range
Dim x As Long, FromCnt As Long

Dim Cell As Range
Dim MyRow As Range
Dim SourceRow As Long
Dim SourceRows As Long
Dim SourceCol As Long
Dim SourceCols As Long

Application.ScreenUpdating = False

'Select the range where it should be pasted.
Set Target = Application.InputBox _
(Prompt:="Select the first cell in the Paste range", Type:=8)

SourceRows = CopyRng.Rows.Count
SourceCols = CopyRng.columns.Count
SourceRow = 1
SourceCol = 1
For Each MyRow In Target
For Each Cell In MyRow.Cells
If Cell.Visible = True Then
StartWS.Cells(SourceRow, SourceCol).Copy _
Destination:=Cell
'increment to next cell
If SourceCol = SourceCols Then
SourceRow = SourceRow + 1
SourceCol = 1
Else
SourceCol = SourceCol + 1
End If
End If
Next Cell
Next MyRow
Application.ScreenUpdating = True
End Sub

 

[Abdul]

Thanks..

I have tried this way of course a working solution I have .. I need to
get this run through a userform..

 

[Joel]

Thanks..

I have tried this way of course a working solution I have .. I need to
get this run through a userform..

 

[Joel]

Why doesn't work with a userform? Are some cells protected? You may have
to create an array of the cells you want to Copy

SourceArray = Array("A1","B2", "C3")


or

set SourceRange = Range("A1","B2","C3")

 

[Rick Rothstein]

I think you code might be able to be made much simpler than what you are
using; but before I can know for sure, are your ranges *always* contiguous
or do you allow for non-contiguous ranges as well?

 

[Abdul]

Thanks for all the effort and replys.. as I mentioned I have this
working solution. But does your answer related to my question? where
is the user from involved here? I dont want to get a wait time for the
user. The user will be selecting the worksheet and range (can be
resttricted to one column) of his choice and the destination as well.
Of course both source and destination may contain hidden which i want
to avoid. Copying is simple but pasting is difficult.

Thanks again

 

[OssieMac]

Hello Abdul,

I posted put some code on a previous post of your relating to this but here
is a modified version. It will run from a Userform but you should set the
Userform ShowModal property to False.

The code and userform can be in any workbook. It does not necessarily have
to be in the Source data or Destination data workbook.

It works for Hidden rows only. Have done nothing with hidden columns.

You will have to edit the code to set the wbSource and wbDestin workbook
variables. You might want to do this with additional code to be run prior to
the InputBoxes but both the Source and Destination workbooks need to be open
before the code gets to the Inputboxes.

With the first InputBox simply select the full range to be copied. Does not
matter if it appears to include hidden rows because the code will exclude
hidden rows.

With the second InputBox select the first visible cell only of the
destination. The code will handle identifying the required visible cells for
the paste. It pastes one row at a time.

Private Sub CopyVisibleData_Click()

Dim wbSource As Workbook
Dim wbDestin As Workbook
Dim rngSource As Range
Dim rngDestin As Range
Dim lngTotCols As Long
Dim DestinOffset()
Dim i As Long
Dim j As Long
Dim rngCel As Range

'NOTE: Code works from any workbook,
'or stand alone workbook.
Set wbSource = Workbooks("Visible Cells Source.xls")
Set wbDestin = Workbooks("Visible Cells Destin.xls")

'Must activate required workbook before
'InputBox code.
wbSource.Activate

On Error Resume Next
Set rngSource = Application.InputBox _
(prompt:="Select Source Range to Copy", _
Title:="Source Selection", Type:=8)
On Error GoTo 0

If rngSource Is Nothing Then
MsgBox "User clicked Cancel." & vbCrLf & _
"Processing terminated."
Exit Sub
End If

'Save the total number of columns for Offset
lngTotCols = rngSource.Columns.Count

'Alter selection to one column only and
'Exclude hidden cells from the selected range.
'Selecting one row only results in entire
'column to bottom of page being assigned
'to rngSource and hense the If/Else/End If.
If rngSource.Rows.Count > 1 Then
Set rngSource = rngSource.Columns(1) _
.SpecialCells(xlCellTypeVisible)
Else
Set rngSource = rngSource.Cells(1, 1)
End If

'Must activate required workbook before
'InputBox code.
wbDestin.Activate

DestinSelect:
On Error Resume Next
Set rngDestin = Application.InputBox _
(prompt:="Select destination workbook and worksheet" _
& vbCrLf & "Select FIRST cell only of destination", _
Title:="Destination Selection", Type:=8)
On Error GoTo 0

If rngDestin Is Nothing Then
MsgBox "User clicked Cancel." & vbCrLf & _
"Processing terminated."
Exit Sub
End If

If rngDestin.Cells.Count <> 1 Then
MsgBox "Must select one visible cell only"
GoTo DestinSelect
End If

'Create array of destination offsets.
ReDim DestinOffset(1 To rngSource.Cells.Count)

i = 0 'Initialize
j = 0 'Initialize
Do
If rngDestin.Offset(j) _
.EntireRow.Hidden = False Then
i = i + 1
DestinOffset(i) = j
End If
j = j + 1
Loop While i < UBound(DestinOffset)

'Copy and paste the rows from source
'to the destination.
i = 0 'Initialize
For Each rngCel In rngSource
i = i + 1
Range(rngCel, rngCel.Offset _
(0, lngTotCols - 1)).Copy _
Destination:=rngDestin _
.Offset(DestinOffset(i))
Next rngCel

End Sub

 

[Abdul]

Thanks Ossie,

As I have mentioned earlier I cant hard code the source or destination
workbook.

can you give me an example code where the user select the open
workbook through a ComboBox and the range through a RefEdit and user
select the destination workbook through a ComboBox and a Destination
Cell throug a RefEdit

This is the part I am stuck with.

Thanks again for your effort... ,

 

[OssieMac]

Hellow again Abdul,

Now I think I understand the problem better. Previously I thought that it
just was not working in conjunction with the Userform and that you knew how
to code the Userform part. However, a couple of questions first because I am
not sure how much code you really need.

Have you already populated the workbook names in the ComboBox lists (for
both Source and Destination)?

If you haven't done the above, is that what you also need help with? If so,
I need some information regarding a file filter like "Source*.xls" and
"Destination*.xls" so the correct files can be gathered for the lists.

Does the path have to be selected or can it be hard coded? (If hard coded
then I can mark that in the code for you to edit.)

If you have not already populated the workbook names in the ComboBox list
and you need the user to select both path and file name then perhaps I can
suggest using the Workbook Open dialog box and use a command button to invoke
it. The user can then select both the path and file name in the one
operation. Let me know your decision.

Do you want to be able to make all the selections on the form and then have
a separate command button to process it. Obviously the workbooks need to be
opened in the afterupdate event of the comboboxes so that the RefEdit
selections can be made. I prefer a button to execute the copy/paste code
after the selections are made because it gives the user a chance to review
the selections and make changes if necessary.

Will wait to hear from you.

 

[OssieMac]

Hello again Abdul,

I didn’t wait for your reply and I have done some work on this using my
preferred FileDialog method for selecting both the Source and Destination
workbooks. You should be able to easily convert the FileDialog section to
Combo Box selection if you want but I suggest that you try my code unaltered
until you see what it should be doing.

However, I have had some problems with RefEdit controls. I searched the
internet for answers and it appears they have had bugs since their inception.
Most of the Events do not work properly, some do not work at all and some
cause lockups of Excel so I have totally avoided using the Events associated
with these controls.

If you want to test my code then firstly backup your workbooks.

Open a new workbook for the Userform and code.

Insert a Userform and then insert the following controls. (What you use for
captions is optional. I have included captions so you know what each control
is for.)

CommandButton1 with caption "Find Source Workbook"
CommandButton2 with caption "Find Destination Workbook"
CommandButton3 with caption "Copy and Paste Data"
CommandButton4 with caption "Activate Source Workbook"
CommandButton5 with caption "Activate Destination Workbook"

RefEdit1 Used for the selected Source range.
RefEdit2 Used for the selected Destination range.

Buttons 1 and 2 open the FileDialogBox so you can select the Source and
Destination workbooks respectively.

Buttons 4 and 5 activate the required workbook (Source or Destination) so
that the ranges can be selected for RefEdit1 and RefEdit2. Refedit controls
are only enabled while their respective workbook is the Active Workbook to
prevent range selections in the incorrect workbook being made.

Button 3 Copies and Pastes the data.

I then suggest that you insert a command button on a worksheet in the
workbook to run the following code to open the Userform.

Private Sub CommandButton1_Click()
UserForm1.Show
End Sub

Copy all of the below code into the Userform code module and make the
following alterations to suit your situation.

In the code under the following subs:-
Private Sub CommandButton1_Click() and also in
Private Sub CommandButton2_Click()
Edit the following line for your required path for the workbooks. Does not
matter if both the same. I have used the variable CurDir but you can use a
valid string instead like.
"C\Users\UserName\Documents\Excel\Source"

strPath = CurDir 'Change this line

Then just below edit the following line for the workbook name filters.

strFilename = "Visible cells s*.xls*" 'Change this line

DON’T FORGET TO DO THE ABOVE 2 STEPS IN BOTH SUBS.


NOTE: I have not been able to work out a way of automatically activating the
required workbook to bring it to the top for the RefEdit fields. The only way
I have had any success is to use a separate button. However, when the button
is clicked, it sets the focus to the required RefEdit field ready for
selecting the range so it does not really incorporate an extra step

'*************************************
'Note: Dim statements between asterisk
'lines must be at top of VBA editor in
'The Declarations area prior to any subs.

Dim wbSource As Workbook
Dim wbDestin As Workbook
Dim strFileShort As String
Dim rngSource As Range
Dim rngDestin As Range
'*************************************

Private Sub UserForm_Initialize()
Me.RefEdit1.Enabled = False
Me.RefEdit2.Enabled = False
Me.CommandButton4.Enabled = False
Me.CommandButton5.Enabled = False

End Sub

Private Sub CommandButton1_Click()
'This routine to get the source workbook

Dim strTitle As String
Dim strPath As String
Dim strFilename As String
Dim strFileFilter As String


'Edit following line to Source path.
strPath = CurDir

'Edit following line to Source name filter.
strFilename = "Visible cells s*.xls*"


strFileFilter = strPath & "\" & strFilename

strTitle = "Select required source file"

'Calls sub to open FilePicker DialogBox
Call OpenWorkbook(strTitle, strFileFilter)

Set wbSource = Nothing
On Error Resume Next
Set wbSource = Workbooks(strFileShort)
On Error GoTo 0

If wbSource Is Nothing Then
Application.AutomationSecurity _
= msoAutomationSecurityLow

Set wbSource = Workbooks.Open _
(strFileShort, _
UpdateLinks:=False, _
ReadOnly:=False)

Application.AutomationSecurity _
= msoAutomationSecurityByUI

End If

Me.CommandButton4.Enabled = True
Me.RefEdit1.Enabled = True
Me.RefEdit1.SetFocus
Me.RefEdit2.Enabled = False
wbSource.Activate

If Not wbDestin Is Nothing Then
Me.CommandButton5.Enabled = True
Else
Me.CommandButton5.Enabled = False
End If

End Sub

Private Sub CommandButton2_Click()
'This routine to get the Destination workbook

Dim strTitle As String
Dim strPath As String
Dim strFilename As String
Dim strFileFilter As String

strTitle = "Select required destination file"

'Edit following line to Destination path.
strPath = CurDir

'Edit following line to Destination name filter.
strFilename = "Visible cells d*.xls*"

strFileFilter = strPath & "\" & strFilename

'Calls sub to open FilePicker DialogBox
Call OpenWorkbook(strTitle, strFileFilter)

Set wbDestin = Nothing
On Error Resume Next
Set wbDestin = Workbooks(strFileShort)
On Error GoTo 0

If wbDestin Is Nothing Then
Application.AutomationSecurity = _
msoAutomationSecurityLow

Set wbDestin = Workbooks.Open _
(strFileShort, _
UpdateLinks:=False, _
ReadOnly:=False)

Application.AutomationSecurity _
= msoAutomationSecurityByUI

End If

Me.CommandButton5.Enabled = True
Me.RefEdit2.Enabled = True
Me.RefEdit2.SetFocus
Me.RefEdit1.Enabled = False
wbDestin.Activate

If Not wbSource Is Nothing Then
Me.CommandButton4.Enabled = True
Else
Me.CommandButton4.Enabled = False
End If


End Sub

Private Sub CommandButton3_Click()
'This routine:
'Assigns the RefEdit data to range variables.
'Excludes the hidden ranges in the variables.
'Creates an array for the destination offsets.
'Copies and pastes the data by rows using a loop.

Dim strWsName As String
Dim strAddress As String

Dim lngTotCols As Long
Dim DestinOffset()
Dim i As Long
Dim j As Long
Dim rngCel As Range

'Bring Destination workbook to top
wbDestin.Activate

'Assign RefEdit1 range to a range variable
strWsName = Left(Me.RefEdit1, _
InStr(1, Me.RefEdit1, "!") - 1)

strAddress = Mid(Me.RefEdit1, _
InStr(1, Me.RefEdit1, "$"))

Set rngSource = wbSource.Sheets _
(strWsName).Range(strAddress)

'Save the total number of columns for Offset.
lngTotCols = rngSource.Columns.Count

'Exclude hidden cells from the range.
If rngSource.Rows.Count > 1 Then
Set rngSource = rngSource.Columns(1) _
.SpecialCells(xlCellTypeVisible)
Else
Set rngSource = rngSource.Cells(1, 1)
End If

'Assign RefEdit2 range to a range variable
strWsName = Left(Me.RefEdit2, _
InStr(1, Me.RefEdit2, "!") - 1)

strAddress = Mid(Me.RefEdit2, _
InStr(1, Me.RefEdit2, "$"))

Set rngDestin = wbDestin.Sheets _
(strWsName).Range(strAddress)

If rngDestin.Cells.Count <> 1 Then
MsgBox "Please re-select destination." & _
vbCrLf & "Select ONE visible cell only."
wbDestin.Activate
Me.RefEdit2.SetFocus
Exit Sub
End If

'Create array of destination offsets.
ReDim DestinOffset(1 To rngSource.Cells.Count)

i = 0 'Initialize
j = 0 'Initialize
Do
If rngDestin.Offset(j) _
.EntireRow.Hidden = False Then
i = i + 1
DestinOffset(i) = j
End If
j = j + 1
Loop While i < UBound(DestinOffset)

'Loop to copy and paste the rows
'from source to the destination.
i = 0 'Initialize
For Each rngCel In rngSource
i = i + 1
Range(rngCel, rngCel.Offset _
(0, lngTotCols - 1)).Copy _
Destination:=rngDestin _
.Offset(DestinOffset(i))
Next rngCel

End Sub

Private Sub CommandButton4_Click()
'This routine to re-activate the
'Source workbook if already open.

If Not wbSource Is Nothing Then
wbSource.Activate

Me.RefEdit1.Enabled = True
Me.RefEdit1.SetFocus
Me.RefEdit2.Enabled = False
Else
MsgBox "Source workbook not open"
End If

End Sub

Private Sub CommandButton5_Click()
'This routine to re-activate the
'Destinatione workbook if already open.

If Not wbDestin Is Nothing Then
wbDestin.Activate
Me.RefEdit2.Enabled = True
Me.RefEdit2.SetFocus
Me.RefEdit1.Enabled = False
Else
MsgBox "Destination workbook not open"
End If
End Sub

Sub OpenWorkbook(strTitle As String, _
strFileFilter As String)
'This routine opens FileDialog and is
'called from both CommandButton1_Click
'and CommandButton2_Click.

Dim fd As FileDialog
Dim strFileLong As String
'Dim strFileShort As String

Set fd = Application.FileDialog _
(msoFileDialogFilePicker)

With fd
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add _
"All Microsoft Excel Files", "*.xls*"

.InitialFileName = strFileFilter
.Title = strTitle
If .Show = False Then
MsgBox "User cancelled." & vbCrLf & _
"Processing terminated."
Exit Sub
End If
strFileLong = .SelectedItems(1)
End With

strFileShort = Right(strFileLong, _
Len(strFileLong) - _
InStrRev(strFileLong, "\"))

End Sub

 

[Abdul]

Thanks for all your time and effort..

I will check this and post back
Thanks again.