Copy Range to Another Workbook
 

Dear gentlemen

I am running a procedure based on John Walkenbach's code for copying
different ranges, but only works on the active workbook, is there a way to
make it able to select a different workbook as the destination range?

Here is the code:

Dim SelAreas() As Range
Dim PasteRange As Range
Dim Upperleft As Range
Dim NumAreas As Long, i As Long
Dim TopRow As Long, LeftCol As Long
Dim RowOffset As Long, ColOffset As Long

If TypeName(Selection) < "Range" Then Exit Sub

' Store the areas as separate Range objects
NumAreas = Selection.Areas.Count
ReDim SelAreas(1 To NumAreas)
For i = 1 To NumAreas
Set SelAreas(i) = Selection.Areas(i)
Next

' Determine the upper-left cell in the multiple selection
TopRow = ActiveSheet.Rows.Count
LeftCol = ActiveSheet.Columns.Count
For i = 1 To NumAreas
If SelAreas(i).Row < TopRow Then TopRow = SelAreas(i).Row
If SelAreas(i).Column < LeftCol Then LeftCol = SelAreas(i).Column
Next
Set Upperleft = Cells(TopRow, LeftCol)

' Get the paste address
On Error Resume Next
Set PasteRange = Application.InputBox(Prompt:="Specify the upper-left
cell for the paste range: ", _
Title:="Copy Multiple Selection", _
Type:=8)
On Error GoTo 0

' Exit if cancelled
If TypeName(PasteRange) < "Range" Then Exit Sub

' Make sure only the upper-left cell is used
Set PasteRange = PasteRange.Range("A1")

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)
Next i
End Sub

Your help will be grately appreciated.

Thanks & regards
farid2001

Copy Range to Another Workbook
 

Please replace ActiveSheet. with

Workbooks("Book1").Sheets("Sheet1").

OR if you can use variables like

strWrkBook = "Book1"
strWrkSheet = "Sheet1"

Workbooks(strWrkBook).Sheets(strWrkSheet).


If this post helps click Yes
---------------
Jacob Skaria


"farid2001" wrote:

Dear gentlemen

I am running a procedure based on John Walkenbach's code for copying
different ranges, but only works on the active workbook, is there a way to
make it able to select a different workbook as the destination range?

Here is the code:

Dim SelAreas() As Range
Dim PasteRange As Range
Dim Upperleft As Range
Dim NumAreas As Long, i As Long
Dim TopRow As Long, LeftCol As Long
Dim RowOffset As Long, ColOffset As Long

If TypeName(Selection) < "Range" Then Exit Sub

' Store the areas as separate Range objects
NumAreas = Selection.Areas.Count
ReDim SelAreas(1 To NumAreas)
For i = 1 To NumAreas
Set SelAreas(i) = Selection.Areas(i)
Next

' Determine the upper-left cell in the multiple selection
TopRow = ActiveSheet.Rows.Count
LeftCol = ActiveSheet.Columns.Count
For i = 1 To NumAreas
If SelAreas(i).Row < TopRow Then TopRow = SelAreas(i).Row
If SelAreas(i).Column < LeftCol Then LeftCol = SelAreas(i).Column
Next
Set Upperleft = Cells(TopRow, LeftCol)

' Get the paste address
On Error Resume Next
Set PasteRange = Application.InputBox(Prompt:="Specify the upper-left
cell for the paste range: ", _
Title:="Copy Multiple Selection", _
Type:=8)
On Error GoTo 0

' Exit if cancelled
If TypeName(PasteRange) < "Range" Then Exit Sub

' Make sure only the upper-left cell is used
Set PasteRange = PasteRange.Range("A1")

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)
Next i
End Sub

Your help will be grately appreciated.

Thanks & regards
farid2001

Copy Range to Another Workbook
 

It depends on how you will specify the different workbook.
If you know the workbook in advance then add the 3rd and 4th lines shown below...
'--
' Make sure only the upper-left cell is used
Set PasteRange = PasteRange.Range("A1")
Set PasteRange = _
Workbooks("Different.xls").Worksheets(1).Range(Pas teRange.Address)
'--
Or you can replace the InputBox with a RefEdit control on a UserForm.
That would give the user the flexibility to actually select a sheet in another workbook.
However, RefEdit controls have a deserved reputation for being difficult.

Peter Thornton recently pointed the way to a download that
contains a UserForm - using two RefEdit controls.
It allows you to make separate selections, for a workbook and a range...
http://www.jkp-ads.com/Articles/SelectARange.asp
You might be able to drop the whole thing into your project.
'--
Jim Cone
Portland, Oregon USA




"farid2001"

wrote in message
Dear gentlemen

I am running a procedure based on John Walkenbach's code for copying
different ranges, but only works on the active workbook, is there a way to
make it able to select a different workbook as the destination range?

Here is the code:

Dim SelAreas() As Range
Dim PasteRange As Range
Dim Upperleft As Range
Dim NumAreas As Long, i As Long
Dim TopRow As Long, LeftCol As Long
Dim RowOffset As Long, ColOffset As Long

If TypeName(Selection) < "Range" Then Exit Sub

' Store the areas as separate Range objects
NumAreas = Selection.Areas.Count
ReDim SelAreas(1 To NumAreas)
For i = 1 To NumAreas
Set SelAreas(i) = Selection.Areas(i)
Next

' Determine the upper-left cell in the multiple selection
TopRow = ActiveSheet.Rows.Count
LeftCol = ActiveSheet.Columns.Count
For i = 1 To NumAreas
If SelAreas(i).Row < TopRow Then TopRow = SelAreas(i).Row
If SelAreas(i).Column < LeftCol Then LeftCol = SelAreas(i).Column
Next
Set Upperleft = Cells(TopRow, LeftCol)

' Get the paste address
On Error Resume Next
Set PasteRange = Application.InputBox(Prompt:="Specify the upper-left
cell for the paste range: ", _
Title:="Copy Multiple Selection", _
Type:=8)
On Error GoTo 0

' Exit if cancelled
If TypeName(PasteRange) < "Range" Then Exit Sub

' Make sure only the upper-left cell is used
Set PasteRange = PasteRange.Range("A1")

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)
Next i
End Sub

Your help will be grately appreciated.

Thanks & regards
farid2001

Copy Range to Another Workbook
 

Correction...
The download actually uses a ComboBox and a RefEdit control,
not two RefEdit controls.
'--
Jim Cone

Copy Range to Another Workbook
 

Thanks Jim, your reply has been very helpfull

Regards
farid2001
"Jim Cone" wrote:

Correction...
The download actually uses a ComboBox and a RefEdit control,
not two RefEdit controls.
'--
Jim Cone

Copy Range to Another Workbook
 

Jacob, thanks a lot for your reply.
It was very helpfull

Regards
farid2001

"Jacob Skaria" wrote:

Please replace ActiveSheet. with

Workbooks("Book1").Sheets("Sheet1").

OR if you can use variables like

strWrkBook = "Book1"
strWrkSheet = "Sheet1"

Workbooks(strWrkBook).Sheets(strWrkSheet).


If this post helps click Yes
---------------
Jacob Skaria


"farid2001" wrote:

Dear gentlemen

I am running a procedure based on John Walkenbach's code for copying
different ranges, but only works on the active workbook, is there a way to
make it able to select a different workbook as the destination range?

Here is the code:

Dim SelAreas() As Range
Dim PasteRange As Range
Dim Upperleft As Range
Dim NumAreas As Long, i As Long
Dim TopRow As Long, LeftCol As Long
Dim RowOffset As Long, ColOffset As Long

If TypeName(Selection) < "Range" Then Exit Sub

' Store the areas as separate Range objects
NumAreas = Selection.Areas.Count
ReDim SelAreas(1 To NumAreas)
For i = 1 To NumAreas
Set SelAreas(i) = Selection.Areas(i)
Next

' Determine the upper-left cell in the multiple selection
TopRow = ActiveSheet.Rows.Count
LeftCol = ActiveSheet.Columns.Count
For i = 1 To NumAreas
If SelAreas(i).Row < TopRow Then TopRow = SelAreas(i).Row
If SelAreas(i).Column < LeftCol Then LeftCol = SelAreas(i).Column
Next
Set Upperleft = Cells(TopRow, LeftCol)

' Get the paste address
On Error Resume Next
Set PasteRange = Application.InputBox(Prompt:="Specify the upper-left
cell for the paste range: ", _
Title:="Copy Multiple Selection", _
Type:=8)
On Error GoTo 0

' Exit if cancelled
If TypeName(PasteRange) < "Range" Then Exit Sub

' Make sure only the upper-left cell is used
Set PasteRange = PasteRange.Range("A1")

' Copy and paste each area
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
SelAreas(i).Copy PasteRange.Offset(RowOffset, ColOffset)
Next i
End Sub

Your help will be grately appreciated.

Thanks & regards
farid2001

Copy Range to Another Workbook
 

I worked around an easy way out.

' Get the paste address
On Error Resume Next
Windows("wkbook2.xlsx").Activate
Set PasteRange = Application.InputBox(Prompt:="Specify the upper-left
cell for the paste range: ", _
Title:="Copy Multiple Selection", _
Type:=8)
On Error GoTo 0
This opens the other workbook and lets me choose the wksheet and range also.

Regards
farid2001


"farid2001" wrote:

Thanks Jim, your reply has been very helpfull

Regards
farid2001
"Jim Cone" wrote:

Correction...
The download actually uses a ComboBox and a RefEdit control,
not two RefEdit controls.
'--
Jim Cone