How to specify multiple separate cells for copy in VBA

[Ed Harris]

Hi,
I have this code originally given to me by ZOT in 2020 and since modified. But now instead of the resize I want to copy multiple separate cells all on the same row dependent on the (r, C) method used in "FirstCell" - somethng like the range I tried to make below but fails.
This must be really simple but I cannot make it work.
Hope you can help

Public Sub GetVariusData() 'searches for coloured cells and collects the cell address, date, wind spd to sheet 2
    Sheets("November").Select
    
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row ' Find the last row of data
    
    For r = 2 To FinalRow  ' Loop through each row
        For C = 121 To 624 'data block
           
            ThisValue = Cells(r, C).Interior.Color
            FirstCell = Cells(r, C).Address
            If ThisValue = RGB(255, 255, 0) Then   ' Decide if to copy based on contents of the row
                'Cells(r, 31).Resize(1, 6).Copy    ' Copy the cells 31 to 31+5 to the clipboard

                'Range("r:487,r:503").Copy       'fails

                
                Sheets("Sheet2").Select ' Set Sheet2 as the current sheet
                NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1 ' Define a variable called nextrow from 2nd column
                Cells(NextRow, 1).Value = FirstCell ' Select the cell on the second column (just a single cell this time)
                Cells(NextRow, 2).Select            ' Paste the stuff we copied earlier
                ActiveSheet.Paste                   ' Set sheet 1 as the active sheet again (because of the loop)
                Sheets("November").Select
            End If
        Next C
    Next r
End Sub

 

[Artik]

First you need to answer the relevant question.
If you copy a non-contiguous range of cells, you paste it into the target cell and get a continuous range. For example, you copy cells from columns A, C, E, G and paste them into a cell in column AA. The pasted range is AA:AD. Are you sure you need this?

Artik

 

[Ed Harris]

Probably, I cannot think what the alternative might be.

 

[Artik]

An alternative could be to paste cells with the same column spacing as in the source range. That is, using the same example as before: you copy A, C, E, G to column AA and get the data in columns AA, AC, AE, AG. But I'm guessing that's not what you mean.

Since I don't quite know what you need I'm assuming that you want to copy a few(-teen) cells from a non-contiguous range from the data row under study if a certain condition is met. The copied cells are to be pasted as a continuous range into the other sheet.

Try this

Sub GetVariusData_2()
    Dim wksNov As Worksheet
    Dim wksSh2 As Worksheet
    Dim NextRow As Long
    Dim FinalRow As Long
    Dim r As Long, C As Long
    
    Application.ScreenUpdating = False
    
    Set wksNov = Worksheets("November")
    Set wksSh2 = Worksheets("Sheet2")

    With wksSh2
        'The first free row in Sheet2
        NextRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
    End With

    With wksNov
        'The last row in November
        FinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        For r = 2 To FinalRow
            For C = 121 To 624

                If .Cells(r, C).Interior.Color = RGB(255, 255, 0) Then
                    'Range("r:487,r:503").Copy       'fails
                    
                    'Into cell A in Sheet2, insert the address of the cell from sheet November
                    wksSh2.Cells(NextRow, 1).Value = .Cells(r, C).Address
                    
                    'Copy the discontinuous range of data from November and paste into cell B in Sheet2
                    Union(.Cells(r, 487), .Cells(r, 503), .Cells(r, 550), .Cells(r, 600)).Copy Destination:=wksSh2.Cells(NextRow, 2)
                    
                    'Increment the row number by 1 to avoid calculating the row number each time
                    NextRow = NextRow + 1
                End If
                
            Next C
        Next r

    End With
    
    Application.ScreenUpdating = True
End Sub

Artik

 

[Ed Harris]

Thanks so much, it works perfectly and the logic is a bit easier to follow than my old example.