Link to home
Start Free TrialLog in
Avatar of Svgmassive
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$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
Avatar of Robert Schutt
Robert Schutt
Flag of Netherlands image

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

ASKER CERTIFIED SOLUTION
Avatar of Faustulus
Faustulus
Flag of Singapore image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Svgmassive
Svgmassive

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.

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 

Open in new window


hth
Rob