# 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\$21:\$P\$21,\$AE\$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\$21:\$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
###### Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Software EngineerCommented:
The way I read it there are some inconsistencies in the destinations you describe but that should be easy to fix, try this:
``````Sub CopyRange()
Dim rng1 As Range, rng2 As Range
Set rng1 = Sheet1.Range("B:P,AE:AH") ' specify the columns
Set rng2 = Sheet1.Range("2:2,15:15,21:21") ' specify the rows
Application.Intersect(rng1, rng2).Copy Sheet2.[b5]
End Sub
``````
0
Commented:
The following code will do your job. It works on the principle that cell values from a non-contiguous range are copied to a contiguous range. It doesn't copy from non-contiguous to non-contiguous. In order to achieve this effect you must run the same code several times, once for each contiguous target range.
``````Option Explicit

Sub CopyData()

Dim WsS As Worksheet            ' S = Source
Dim WsT As Worksheet            ' T = Target
Dim AnS As String               ' Source range name
Dim AnT As String               ' Target range name

Set WsS = Worksheets("Sheet1")
Set WsT = Worksheets("Sheet2")
Application.ScreenUpdating = False

' first contiguous target range:-
AnS = "B2:P2,B15:P15,B21:P21"           ' non-contiguous, comma separated
AnT = "B4:P7"                    ' contiguous
MoveData AnS, AnT, WsS, WsT

' second contiguous target range:-
AnS = "AE2:AH2,AE15:AH15,AE21:AH21"           ' non-contiguous, comma separated
AnT = "Q4:T7"                    ' contiguous
MoveData AnS, AnT, WsS, WsT

Application.ScreenUpdating = True
End Sub

Private Sub MoveData(ByVal AnS As String, _
ByVal AnT As String, _
WsS As Worksheet, _
WsT As Worksheet)

Dim An() As String              ' Range names
Dim RngT As Range
Dim RngS As Range
Dim T As Long                   ' cell counter for RngT
Dim S As Long                   ' cell counter for RngS
Dim i As Integer                ' index for An()

Set RngT = WsT.Range(AnT)
An = Split(AnS, ",")
For i = LBound(An) To UBound(An)
Set RngS = WsS.Range(An(i))
With RngS
For S = 1 To .Cells.Count
T = T + 1
If T <= RngT.Cells.Count Then
RngT.Cells(T) = .Cells(S)
End If
Next S
End With
Next i
End Sub
``````
Note that the source and target ranges in the code in the attached file are different from the above. The code in the attached workbook is tested, the above is not. If the Target range has fewer cells than the combined source ranges superfluous source cells will not be copied. If the target range has more cells than the combined total of all source cells target cells at the end of the range will not be written to. Note that cells are numbered left to right, top to bottom.

Install the code in a standard code module in your own project. By default the name of that module will be 'Module1'.
In order to run the above code call the procedure 'CopyData'.
In order to modify the code assign values to AnS and AnT as required. AnS can hold any number of non-contiguous ranges >0. You can add as many groups of those 3 lines of code as you may require, one under the other, in any sequence.
Use the attached workbook for testing.
EXX-130909-Copy-Non-contiguous-R.xlsm
0

Experts Exchange Solution brought to you by

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Author Commented:
great
0
Commented:
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.

``````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)

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
0
###### It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Applications

From novice to tech pro — start learning today.