none
Macro to Move Row to a New Worksheet based on Cell Colour RRS feed

  • Question

  • I've written the following macro to allow a team to automatically move rows within an excel spreadsheet to a new sheet if a certain cell meets a certain criteria:

    Sub Downgrade()
        Dim xRg As Range
        Dim xCell As Range
        Dim I As Long
        Dim J As Long
        Dim K As Long
        I = Worksheets("CB & YB July  -Dec 2014 ").UsedRange.Rows.Count
        J = Worksheets("Downgrade").UsedRange.Rows.Count
        If J = 1 Then
           If Application.WorksheetFunction.CountA(Worksheets("Downgrade").UsedRange) = 0 Then J = 0
        End If
        Set xRg = Worksheets("CB & YB July  -Dec 2014 ").Range("C1:C" & I)
        On Error Resume Next
        Application.ScreenUpdating = False
        For K = 1 To xRg.Count
            If CStr(xRg(K).Value) = "X" Then
                xRg(K).EntireRow.Copy Destination:=Worksheets("Downgrade").Range("A" & J + 1)
                xRg(K).EntireRow.Delete
                If CStr(xRg(K).Value) = "X" Then
                    K = K - 1
                End If
                J = J + 1
            End If
        Next
        Application.ScreenUpdating = True
    End Sub

    It works as I'd hoped, but the area have now changed how they update the spreadsheet and are now using cell colour rather than content to identify which rows need to move.

    And that's where I have become stuck!

    Would anyone know what I should place the following line with in order to identify colour rather than letter?

    If CStr(xRg(K).Value) = "X" Then

    Thanks!

    Thursday, November 22, 2018 12:02 PM

Answers

  • Hi KennyCampbell7,

    >>Macro to Move Row to a New Worksheet based on Cell Color

    Please try the following code:

    xRg(K).Interior.Color = vbRed 

    For more information, please see the following link:

    Macro to copy row based on color

    If it still not work, please refer to the following code:

    Sub organize_by_color()
        Dim rws As Long, c As Long, iCLR As Long, ws As Worksheet, wsT As Worksheet
    
        Set ws = ActiveSheet
        Set wsT = Worksheets.Add(after:=Sheets(Sheets.Count))
    
        iCLR = 49407 'Orange e.g. RGB(255, 192, 0)
        wsT.Cells(1, 1).Resize(1, 2) = Array("Job A", "Job B")
    
        With ws.Cells(1, 1).CurrentRegion
            .AutoFilter
            For c = 2 To .Columns.Count
                .AutoFilter Field:=c, Criteria1:=iCLR, Operator:=xlFilterCellColor
                With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
                    rws = Application.Subtotal(103, .Columns(1))
                    If CBool(rws) Then
                        .Columns(1).Copy Destination:=wsT.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
                        wsT.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(rws, 1) = ws.Cells(1, c).Value
                    End If
                End With
                .AutoFilter Field:=c
            Next c
            .AutoFilter
        End With
    
        Set ws = Nothing
        Set wsT = Nothing
    
    End Sub

    For more information, please see the links as below:

    Copy Filtered Row by Color to new sheet

    Hopefully it helps you.

    Best Regards,

    Lina


    MSDN Community Support Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread.


    • Edited by Lina-MSFT Friday, November 23, 2018 5:06 AM
    • Marked as answer by KennyCampbell7 Friday, November 23, 2018 2:31 PM
    Friday, November 23, 2018 5:06 AM

All replies

  • Hi,

    This is the forum to discuss questions and feedback for Microsoft Excel features, I'll move your question to the MSDN forum for Excel

    https://social.msdn.microsoft.com/Forums/en-US/home?forum=exceldev

    The reason why we recommend posting appropriately is you will get the most qualified pool of respondents, and other partners who read the forums regularly can either share their knowledge or learn from your interaction with us. Thank you for your understanding.

    Regards,

    Emi


    Please remember to mark the replies as answers if they helped. If you have feedback for TechNet Subscriber Support, contact tnsf@microsoft.com.


    Click here to learn more. Visit the dedicated forum to share, explore and talk to experts about Microsoft Teams.

    Friday, November 23, 2018 2:46 AM
  • Hi KennyCampbell7,

    >>Macro to Move Row to a New Worksheet based on Cell Color

    Please try the following code:

    xRg(K).Interior.Color = vbRed 

    For more information, please see the following link:

    Macro to copy row based on color

    If it still not work, please refer to the following code:

    Sub organize_by_color()
        Dim rws As Long, c As Long, iCLR As Long, ws As Worksheet, wsT As Worksheet
    
        Set ws = ActiveSheet
        Set wsT = Worksheets.Add(after:=Sheets(Sheets.Count))
    
        iCLR = 49407 'Orange e.g. RGB(255, 192, 0)
        wsT.Cells(1, 1).Resize(1, 2) = Array("Job A", "Job B")
    
        With ws.Cells(1, 1).CurrentRegion
            .AutoFilter
            For c = 2 To .Columns.Count
                .AutoFilter Field:=c, Criteria1:=iCLR, Operator:=xlFilterCellColor
                With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
                    rws = Application.Subtotal(103, .Columns(1))
                    If CBool(rws) Then
                        .Columns(1).Copy Destination:=wsT.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
                        wsT.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(rws, 1) = ws.Cells(1, c).Value
                    End If
                End With
                .AutoFilter Field:=c
            Next c
            .AutoFilter
        End With
    
        Set ws = Nothing
        Set wsT = Nothing
    
    End Sub

    For more information, please see the links as below:

    Copy Filtered Row by Color to new sheet

    Hopefully it helps you.

    Best Regards,

    Lina


    MSDN Community Support Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread.


    • Edited by Lina-MSFT Friday, November 23, 2018 5:06 AM
    • Marked as answer by KennyCampbell7 Friday, November 23, 2018 2:31 PM
    Friday, November 23, 2018 5:06 AM
  • Thanks so much.  That worked
    Friday, November 23, 2018 2:32 PM