Sleeper: Copy multiple non-contiguous selections to other workbook

[ertan]

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

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

[Jacob Hilderbrand]

Try this:

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

[Jacob Hilderbrand]

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 Here

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

[ertan]

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