Copy data from non-contiguous cells

Question

I'd like to automate the copying of data from one non-contiguous range to another. The source and destination have the same number of cells but different range shapes. The following is a simplified graphic to demonstrate.

A simplification of the data:

The source data is in a single column, and non-contiguous. The destination range is where stored data is to be copied to a dashboard.

All suggestions appreciated.

What have you tried? What was your issue? Please explain what is the problem doing it? • You probably need to define which cell goes where. I see no other possibility as there is no pattern where the data should go. — Pᴇʜ, May 31 '21 at 14:31
The source range is where a scenario has been saved. The destination range is where I want to load a previously saved scenario. I have tried looping through the cells of the range, which doesn't work with non-contiguous cells. — Paul Martin, May 31 '21 at 14:42
@PaulMartin It does work. You need 2 loops 1 looping through the areas and one looping through the cells in each area. • Please show the code you have tried ([edit] your question and add it there) so we can show you where your issue was. — Pᴇʜ, May 31 '21 at 14:47

score 1 · Accepted Answer · answered May 31 '21 at 15:56

Copy a Non-Contiguous Range to Another Non-Contiguous Range

Adjust the values in the constants section.

Option Explicit

Sub CopyNonContiguous()
    
    ' Constants
    
    ' Source
    Const sName As String = "Sheet1"
    Const sAddress As String = "G3:G6,G8:G15"
    ' Destination
    Const dName As String = "Sheet1"
    Const dAddress As String = "B3:B4,B6:B7,B9:E10"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Destination Range
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim drg As Range: Set drg = dws.Range(dAddress)
    'drg.Interior.Color = 14348258 ' green
    
    ' Source Range
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range(sAddress)
    'srg.Interior.Color = 13431551 ' yellow
    
    ' Source Data Array
    
    Dim scCount As Long: scCount = srg.Cells.Count
    Dim sData As Variant: ReDim sData(1 To scCount)
    
    ' Additional Variables
    
    Dim arg As Range ' Current Range Area
    Dim cel As Range ' Current Cell in Current Range Area
    Dim n As Long ' Source Data Array Elements Counter
    
    ' Source Range to Source Data Array
    
    For Each arg In srg.Areas
        For Each cel In arg.Cells
            n = n + 1
            'cel.Value = n ' to populate the Source Range
            sData(n) = cel.Value
        Next cel
    Next arg
    
    ' Source Data Array to Destination Range
    
    ' Reset 'n' because at this moment 'n = scCount'.
    n = 0
    For Each arg In drg.Areas
        For Each cel In arg.Cells
            n = n + 1
            cel.Value = sData(n)
            ' Since the Destination Range could contain more cells than
            ' the Source Range, test with the following:
            If n = scCount Then Exit Sub
        Next cel
    Next arg
    
End Sub

Luuk · Answer 2 · 2021-06-01T18:24:02.030

You could 'Record a Macro', and copy all the fields you want to the correct location?

The code that is recorded will look like:

Sub Macro1()
'
' Macro1 Macro
'

'
    Range("G3:G4").Select
    Selection.Copy
    Range("B3").Select
    ActiveSheet.Paste
    Range("G5:G6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("B6").Select
    ActiveSheet.Paste
    Range("G8:G11").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("B9").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("G12:G15").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("B10").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("B12").Select
End Sub

EDIT: Without the Select it could look like this:

Sub macro2()
    Dim a As Worksheet
    Set a = ActiveSheet
    
    a.Range("G3:G4").Copy Destination:=a.Range("B3")
    a.Range("G5:G6").Copy Destination:=a.Range("B6")
    
    a.Range("B9:E9") = Application.WorksheetFunction.Transpose(a.Range("G8:G111"))
    a.Range("B10:E10") = Application.WorksheetFunction.Transpose(a.Range("G12:G15"))
    
End Sub

If that is true, than you should accept it as an answer see: [What should I do when someone answers my question?](https://stackoverflow.com/help/someone-answers) — Luuk, May 31 '21 at 18:49
After recording a macro you really should read [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) and apply that to the recorded code. — Pᴇʜ, Jun 01 '21 at 13:42
Thanks, Pᴇʜ, but I rarely use the Macro Recorder and certainly don't use Select. — Paul Martin, Jun 01 '21 at 17:50

Copy data from non-contiguous cells

2 Answers2

Copy a Non-Contiguous Range to Another Non-Contiguous Range