Svgmassive
asked on
Copy non contiguous range to a different sheet
i have values on sheets 1 in a non contiguous range i would like to copy the values to sheet2
$B$2:$P$2,$B$15:$P$15,$B$2 1:$P$21,$A E$2:$AH$2, $AE$15:$AH $15,$AE$21 :$AH$21
starting from b5 to p5.for example
values in sheet 1 $B$2:$P$2,$B$15:$P$15,$B$2 1:$P$21
would be copied to sheet 2 b4 to p7.
values in sheet 1 $AE$2:$AH$2,$AE$15:$AH$15, $AE$21:$AH $21
would be copied to sheet 2 q4 to t7.
is that possible.i am trying to avoid a loop
thanks
$B$2:$P$2,$B$15:$P$15,$B$2
starting from b5 to p5.for example
values in sheet 1 $B$2:$P$2,$B$15:$P$15,$B$2
would be copied to sheet 2 b4 to p7.
values in sheet 1 $AE$2:$AH$2,$AE$15:$AH$15,
would be copied to sheet 2 q4 to t7.
is that possible.i am trying to avoid a loop
thanks
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
great
hi svgmassive,
I typed this up yesterday but it seems I didn't hit submit. This is not for points as your question is already answered, but I'm adding it to the thread as a potential alternative for others who come across this thread while searching...
***********
Here is a link to a tip (Copying a Multiple Selection) on John Walkenbach's site, which is an oldie but a goody. I have used it & found it reliable in Excel 2000 right through to Excel 2007.
It does use a loop but the loop is already written for you.
hth
Rob
I typed this up yesterday but it seems I didn't hit submit. This is not for points as your question is already answered, but I'm adding it to the thread as a potential alternative for others who come across this thread while searching...
***********
Here is a link to a tip (Copying a Multiple Selection) on John Walkenbach's site, which is an oldie but a goody. I have used it & found it reliable in Excel 2000 right through to Excel 2007.
It does use a loop but the loop is already written for you.
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
hth
Rob
Open in new window