Re: Copy to Visible Cells only;Modify Code

Thanks for all your time and effort..

I will check this and post back
Thanks again.


On Aug 3, 10:29 am, OssieMac <Ossie...@xxxxxxxxxxxxxxxxxxxxxxxxx>
wrote:
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

--
Regards,

OssieMac

.

Relevant Pages

  • Re: Create Right Click Option to Copy Cell Address
    ... I now have a right click menu generated in a regular workbook. ... Private Sub Workbook_BeforeClose ... Dim MyDataObj As New DataObject ... Dim ctrl As CommandBarControl ...
    (microsoft.public.excel.programming)
  • RE: Countdown timer
    ... Just replace your existing code in the Workbook code module with the code ... Notice that one Const is declared outside of the Sub codes. ... Dim RunTime As Variant ... 'NOTE: once DisplayTimeRemaining is called ...
    (microsoft.public.excel.programming)
  • Re: Delete VB code
    ... After you do the sheets copy the new workbook will be the activeworkbook. ... Sub DeleteVBA ... Dim Links As Variant ...
    (microsoft.public.excel.programming)
  • Re: workbook to access
    ... Sub createbk() ... Dim wbkNew As Workbook, srcbk As Workbook ... Dim lng As Long ...
    (microsoft.public.excel.programming)
  • Re: Mail Macro
    ... Dim sh As Worksheet ... Dim TempFilePath As String ... Dim SourceWB As Workbook ...     Dim sh As Worksheet ...
    (microsoft.public.excel.programming)