Skip to content

Copy All Highlighted/Coloured Cells to Another Excel Worksheet

    This video tutorial demonstrates how to copy all coloured/highlighted cells or records to another worksheet using a VBA macro.  In our scenario we have a transaction database and we want to copy all red records (either cell background or font colour) to another worksheet.  You can download the featured file here and copy the featured VBA code below. Please note the featured file doesn’t include the code as I cannot upload macro-enable Excel files to this website.

    VBA code to copy cells with a red background

    Sub CopyHighlightedTransactions()
    
    Dim TransIDField As Range
    Dim TransIDCell As Range
    Dim ATransWS As Worksheet
    Dim HTransWS As Worksheet
    
    Set ATransWS = Worksheets("All Transactions")
    Set TransIDField = ATransWS.Range("A2", ATransWS.Range("A2").End(xlDown))
    Set HTransWS = Worksheets("Highlighted Transactions")
    
    
    For Each TransIDCell In TransIDField
    
        If TransIDCell.Interior.Color = RGB(255, 0, 0) Then
            
            TransIDCell.Resize(1, 10).Copy Destination:= _
                HTransWS.Range("A1").Offset(HTransWS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
                
        End If
    
    Next TransIDCell
    
    HTransWS.Columns.AutoFit
    
    End Sub

    VBA code to copy cells with a red font

    Sub CopyColouredFontTransactions()
    
    Dim TransIDField As Range
    Dim TransIDCell As Range
    Dim ATransWS As Worksheet
    Dim HTransWS As Worksheet
    Dim x As Long
    
    Set ATransWS = Worksheets("All Transactions")
    Set TransIDField = ATransWS.Range("A2", ATransWS.Range("A2").End(xlDown))
    Set HTransWS = Worksheets("Highlighted Transactions")
    
    
    For Each TransIDCell In TransIDField
    
        If TransIDCell.Font.Color = RGB(255, 0, 0) Then
            
            TransIDCell.Resize(1, 10).Copy Destination:= _
                HTransWS.Range("A1").Offset(HTransWS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
                
        End If
    
    Next TransIDCell
    
    HTransWS.Columns.AutoFit
    
    End Sub