Selection.Copy issue

G

greyhound girl

I am trying to copy a combination of a small contiguous range along with one
non-contiguous cell. The Selection.Copy command I am using is returning a
"That command cannot be used on multiple selections". I have not been able to
find the command that will do this. The related code I am using is below:

Sheets("sheet1").Activate
Set r1 = Range("B2:B8")
Set r2 = Range("E1:E1")
Set myMultiAreaRange = Union(r1, r2)
myMultiAreaRange.Select
MsgBox (myMultiAreaRange.Address)
Selection.Copy

Ideas??

Thanks!
 
J

Jim Cone

If the ranges are the same size then the selection will copy...
Set r1 = Range("B2:B8")
Set r2 = Range("E2:E8")
Otherwise, I believe you are stuck with copying and pasting the
individual areas.
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware
(Excel Add-ins / Excel Programming)



"greyhound girl"
<[email protected]>
wrote in message
I am trying to copy a combination of a small contiguous range along with one
non-contiguous cell. The Selection.Copy command I am using is returning a
"That command cannot be used on multiple selections". I have not been able to
find the command that will do this. The related code I am using is below:

Sheets("sheet1").Activate
Set r1 = Range("B2:B8")
Set r2 = Range("E1:E1")
Set myMultiAreaRange = Union(r1, r2)
myMultiAreaRange.Select
MsgBox (myMultiAreaRange.Address)
Selection.Copy

Ideas??
Thanks!
 
D

Duke Carey

You can't copy that range in interactive Excel, nor in VBA.
Just copy each range individually, but you can do so without selecting them

Range("B2:B8").Copy

and if you know where it's going to go, a single command will do that, too

Range("B2:B8").Copy range("C9")

copies your first range to a range beginning with cell C9
 
G

greyhound girl

*sigh* ... guess I'll have to do it with individual copy and paste. Thanks
though!
 
G

greyhound girl

Thanks. Looks like I will have to do some individual copying and pasting but
it's nice to know there isn't some snazzy little method out there I could use
instead. I want waste time looking.
 
L

Limey

Thanks. Looks like I will have to do some individual copying and pasting but
it's nice to know there isn't some snazzy little method out there I could use
instead. I want waste time looking.
Click to expand...

I found this macro on John Walkenbach's site a couple of months ago,
and adapted it to my own needs as an add-in, it allows the user to
select non contiguous ranges of cells, and paste them back to any
worksheet in the workbook. I know that you're after a macro doing
this, but maybe it will help. I hope so.

Sub CopyMultipleSelection()
'Gets around Excel's default behaviour of not allowing a copy to
'clipboard of non-contiguous ranges


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

Cheers!
 
L

Limey

I found this macro on John Walkenbach's site a couple of months ago,
and adapted it to my own needs as an add-in, it allows the user to
select non contiguous ranges of cells, and paste them back to any
worksheet in the workbook. I know that you're after a macro doing
this, but maybe it will help. I hope so.

Sub CopyMultipleSelection()
'Gets around Excel's default behaviour of not allowing a copy to
'clipboard of non-contiguous ranges

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

Cheers!
Click to expand...

I just noticed that some of the lines broke in some weird places, if
you don't want to pick through the code let me know and I'd be happy
to email you the code.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

change InputTitle and InputMessage in columns from row 2 thru 1000 0
Advanced Filters with Unions 1
Sorted data macro not working. Advice request... 3
Apply maco to multiple worksheets request 3
Matching duplicate entries between two columns 2
Copy and Paste LAST ROW of data non-contiguous 6
Putting named range into sub written by Tom Olgivy DataVal 4
Combine 2 columns in a dynamic range into one 7

Top