Copy colored cells only and then delete them from source.

[oldguy46]

Hello,
I need a macro to copy from Sheet1 to Sheet2, columns A and B starting at row 8 (both sheets), but only the values contained in those cells with ColorIndex = 36, and then clear those cells from Sheet1 (values and color), appending the data each time the macro is run. Thank you.

 

[VoG]

Try

Sub clr()
Dim LR As Long, i As Long, r As Range
With Sheets("Sheet1")
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 8 To LR
        If .Range("A" & i).Interior.ColorIndex = 36 And .Range("B" & i).Interior.ColorIndex = 36 Then
            If r Is Nothing Then
                Set r = .Range("A" & i).Resize(, 2)
            Else
                Set r = Union(r, .Range("A" & i).Resize(, 2))
            End If
        End If
    Next i
    If r Is Nothing Then Exit Sub
    With r
        .Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
        .Delete Shift:=xlShiftUp
    End With
End With
End Sub

 

[oldguy46]

The colored cells are dispersed randomly in both columns, but the code is copying only those cells that are adjacent to each other from both columns, not all the colored cells as it is supposed to do.

 

[VoG]

So if A is colored and B isn't, or vice versa, what should happen?

 

[oldguy46]

Both columns in Sheet1 have random colored cells. I need only those cells that are colored to be copied over from Sheet1 to Sheet2. So column A in Sheet2 will contain only the colored cells from column A in Sheet1, and column B in Sheet2 will contain only the colored cells from column B in Sheet1. Then all the colored cells in Sheet1 should disappear. Thank you.

 

[VoG]

Possibly

Sub clr()
Dim LR As Long, i As Long, r As Range, j As Long
With Sheets("Sheet1")
    For j = 1 To 2
        LR = .Cells(Rows.Count, j).End(xlUp).Row
        For i = 8 To LR
            If .Cells(i, j).Interior.ColorIndex = 36 Then
                If r Is Nothing Then
                    Set r = .Cells(i, j)
                Else
                    Set r = Union(r, .Cells(i, j))
                End If
            End If
         Next i
        If r Is Nothing Then Exit For
        With r
            .Copy Destination:=Sheets("Sheet2").Cells(Rows.Count, j).End(xlUp).Offset(1)
            .Delete Shift:=xlShiftUp
        End With
    Next j
End With
End Sub

 

[oldguy46]

I get:

Run-time error '1004':
Method 'Union' of object '_Global' failed.

The first column copies over perfectly but the second column does nothing.

 

[VoG]

Silly me

Sub clr()
Dim LR As Long, i As Long, r As Range, j As Long
With Sheets("Sheet1")
    For j = 1 To 2
        LR = .Cells(Rows.Count, j).End(xlUp).Row
        For i = 8 To LR
            If .Cells(i, j).Interior.ColorIndex = 36 Then
                If r Is Nothing Then
                    Set r = .Cells(i, j)
                Else
                    Set r = Union(r, .Cells(i, j))
                End If
            End If
         Next i
        If r Is Nothing Then Exit For
        With r
            .Copy Destination:=Sheets("Sheet2").Cells(Rows.Count, j).End(xlUp).Offset(1)
            .Delete Shift:=xlShiftUp
        End With
        Set r = Nothing
    Next j
End With
End Sub

 

[oldguy46]

OK, now everything works as it should. Thank you for all you help.