Sleeper: Copy multiple non-contiguous selections to other workbook

Hello to all,

Actually I have post this question to Mr Excel forum. But I cannot get any answer up-to now..
I wonder if anyone can help me this..

am trying to copy multiple cell selections (non-contiguous ) to from one workbook to other.

I have found http://www.j-walk.com/ss/excel/tips/tip36.htm . But it does
only copy one sheet to other sheet in same workbook.

The CopyMultipleSelection Subroutine

Code:

---

Option Explicit

Sub CopyMultipleSelection()
Dim SelAreas() As Range
Dim PasteRange As Range
Dim UpperLeft As Range
Dim NumAreas As Integer, i As Integer
Dim TopRow As Long, LeftCol As Integer
Dim RowOffset As Long, ColOffset As Integer
Dim NonEmptyCellCount As Integer
' Exit if a range is not selected
If TypeName(Selection) <> "Range" Then
MsgBox "Select the range to be copied. A multiple selection is allowed."
Exit Sub
End If
' 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 Mutliple Selection", _
Type:=8)
On Error GoTo 0
' Exit if canceled
If TypeName(PasteRange) <> "Range" Then Exit Sub
' Make sure only the upper left cell is used
Set PasteRange = PasteRange.Range("A1")
' Check paste range for existing data
NonEmptyCellCount = 0
For i = 1 To NumAreas
RowOffset = SelAreas(i).Row - TopRow
ColOffset = SelAreas(i).Column - LeftCol
NonEmptyCellCount = NonEmptyCellCount + _
Application.CountA(Range(PasteRange.Offset(RowOffset, ColOffset), _
PasteRange.Offset(RowOffset + SelAreas(i).Rows.Count - 1, _
ColOffset + SelAreas(i).Columns.Count - 1)))
Next i
' If paste range is not empty, warn user
If NonEmptyCellCount <> 0 Then _
If MsgBox("Overwrite existing data?", vbQuestion + vbYesNo, _
"Copy Multiple Selection") <> vbYes Then Exit Sub
' 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

---

Is there a way to modify to idea to make it work between different workbooks?
Or any other suggestions?
Regards
Ertan

Try this:

Code:

---

SelAreas(i).Copy Workbooks("MyWorkBookName").Sheets("MySheetName").Range(PasteRange.Address).Offset(RowOffset, ColOffset)

---

Also I editted your post to use the VBA tags. Notice how the code looks like it should instead of just regular text. To use the VBA tags put it in this format:

Code:

---

Code Here

---

When you really do it replace the parentheses with brackets []

Dear Jacob,

Thank you for your help.
I will post the vba code between tags it looks much better, and easy to understand.

For the code adjustment , I am afraid I couldnt get it work.

I have just replace the last line of the code with the one you provide.
I have changed the "MyWorkbookName" to source book name and the "MyWorksheetName" to source book sheet name.

I have past this code to destination workbook module.

When I run the code , inputbox comes up for marking where the paste should start.
But nothing happens.

I cannot switch the other workbook..

What I realy want do is :

Load the specific workbook, select multiple areas , copy them to
destination workbook .
(source workbooks will be be more then one , I will load them accordingly
select some multi-cells to copy and paste to destination workbook)
Is it possible?

Regards
Ertan