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

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.

Robert SchuttSoftware 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

Open in new window

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

Open in new window

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.

Experts Exchange Solution brought to you by

Your issues matter to us.

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

Start your 7-day free trial
SvgmassiveAuthor 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)
'   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
    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", _
    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 

Open in new window

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.