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

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

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

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

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

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

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