F
farid2001
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
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