Select data and paste macro problems

[Ed Harris]

I have tried to adapt this macro from working on an adjacent array to working on a single column. The original macro put the data in a new sheet but I want it in column j
There are no bugs but it is not working even to paste in another sheet. Can someone help please.

Public Sub Getcolourcont() 'searches for coloured cells and collects the cell address,
    ' Find the last row of data
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    ' Loop through each row
    For r = 2 To FinalRow
        For C = 1 To 1
            ThisValue = Cells(r, C).Interior.Color
            FirstCell = Cells(r, C).Address
            If ThisValue = RGB(0, 255, 255) Then  ' Decide if to copy based on contents of the row
                Cells(r, 1).Resize(1, 6).Copy       ' Copy the cells 1 to 6 to the clipboard
                Sheets("Sheet2").Select
                NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1 'specify cell to paste at destination
                Cells(NextRow, 1).Value = FirstCell 'paste the cell address
                Cells(NextRow, 2).Select
                ActiveSheet.Paste
                Sheets("Sheet5").Select
            End If
        Next C
    Next r
End Sub

Beam2 2022.xlsm
	A	B	C	D	E	F	G
27	73.43705	44853.5	11.4	1	0	0	0
28	73.43762	44853.5	11.4	1	0	0	0
29	73.43653	44853.5	11.4	1	0	0	0
30	73.53633	44853.5	11.4	1	0	0	0
31	73.43596	44853.5	11.4	1	0	0	0
32	73.43612	44853.5	11.4	1	0	0	0
33	73.43681	44853.5	11.6	1	0	0	0
34	73.43787	44853.5	11.5	1	0	0	0
Sheet5

 

[Zot]

It is not really clear what you were trying to do, so I just guess.

Here is what my code does:
Loop through column A of Sheet1
If cell color is Cyan (RGB(0, 255,255) then write the cell address in column A of Sheet2 and also copy column A to F to Sheet2 starting from row 2 and so on.

Public Sub Getcolourcont() 'searches for coloured cells and collects the cell address,

Dim cell As Range, rngColA As Range
Dim r As Long, C As Long, ThisValue As Long, NextRow As Long
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")

' Define column A range
Set rngColA = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))

' Loop through each row in column A
For Each cell In rngColA
    ThisValue = cell.Interior.Color
    If ThisValue = RGB(0, 255, 255) Then
        NextRow = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
        ws2.Range("A" & NextRow) = cell.Address(0, 0)
        cell.Resize(1, 6).Copy ws2.Range("B" & NextRow)
    End If
Next

End Sub

 

[Ed Harris]

Yess that works - also I found my error the RGB designation should have been 255,255,0. Many thanks, do you know how to write the data to column J in the source sheet instead of a new sheet?

 

[Zot]

Yess that works - also I found my error the RGB designation should have been 255,255,0. Many thanks, do you know how to write the data to column J in the source sheet instead of a new sheet?

Try this. Hope this work. About to go to sleep now in my time zone. Got to wake up early to see doctor in morning

Public Sub Getcolourcont() 'searches for coloured cells and collects the cell address,

Dim cell As Range, rngColA As Range
Dim r As Long, C As Long, ThisValue As Long, NextRow As Long
Dim ws1 As Worksheet

Set ws1 = ActiveWorkbook.Sheets("Sheet1")

' Define column A range
Set rngColA = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))

' Loop through each row in column A
For Each cell In rngColA
    ThisValue = cell.Interior.Color
    If ThisValue = RGB(255, 255, 0) Then
        NextRow = ws1.Cells(Rows.Count, "J").End(xlUp).Offset(1).Row          ' Find next row in column J
        ws1.Range("J" & NextRow) = cell.Address(0, 0)
        cell.Resize(1, 6).Copy ws1.Range("J" & NextRow)
    End If
Next

End Sub

 

[Zot]

Oopss mistake. I paste copied data on address. Should be
cell.Resize(1, 6).Copy ws1.Range("K" & NextRow)
Here's correction

Public Sub Getcolourcont() 'searches for coloured cells and collects the cell address,

Dim cell As Range, rngColA As Range
Dim r As Long, C As Long, ThisValue As Long, NextRow As Long
Dim ws1 As Worksheet

Set ws1 = ActiveWorkbook.Sheets("Sheet1")

' Define column A range
Set rngColA = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))

' Loop through each row in column A
For Each cell In rngColA
    ThisValue = cell.Interior.Color
    If ThisValue = RGB(255, 255, 0) Then
        NextRow = ws1.Cells(Rows.Count, "J").End(xlUp).Offset(1).Row          ' Find next row in column J
        ws1.Range("J" & NextRow) = cell.Address(0, 0)
        cell.Resize(1, 6).Copy ws1.Range("K" & NextRow)
    End If
Next

End Sub