HiveBrain v1.2.0
Get Started
← Back to all entries
patternMinor

Highlighting and copying spreadsheet rows that match a criterion

Submitted by: @import:stackexchange-codereview··
0
Viewed 0 times
codereviewexcelstackoverflowperformancevba
rowshighlightingmatchspreadsheetcopyingthatandcriterion

Problem

I use the code (provided below) to check for certain criteria in a row. In this case, if cell F in worksheet "Swivel" contains "After Dispute For SBU" then that row needs to be highlighted in yellow and the text changed to red, then the row needs to be copied to another sheet named "Disputed" that is within the same workbook. I have added some code to remove the highlight and the font color change if the row is removed from the workbook manually and then the code is triggered again. This particular code is run from a menu system that I created (code not included). The additional code is also used to protect the color of the header row.

This updated code is causing erratic behavior of the cursor and is also running a little longer than it was before the changes, even though the amount of data did not change. Is there a way to improve the code? or is this normal behavior that I need to live with?

The code is completing the tasks as expected.

```
Sub Highlight_Copy_Disputed()

Application.ScreenUpdating = False

' This part highlights all rows that are Disputed
Dim row As Range
For Each row In ActiveSheet.UsedRange.Rows
If row.Cells(1, "F").Value = "After Dispute For SBU" Then
row.Interior.ColorIndex = 6
row.Font.Color = RGB(255, 0, 0)
ElseIf row.Cells(1, "F").Value = "Impact Status" Then
row.Interior.Color = RGB(197, 190, 151)
row.Font.Color = RGB(0, 0, 0)
Else
row.Interior.ColorIndex = xlNone
row.Font.Color = RGB(0, 0, 0)
End If
Next row

' This part clears the Disputed worksheet and copies all disputed rows to the sheet

With ThisWorkbook.Worksheets("Disputed")
Range(.Range("A2"), .UsedRange.Offset(1, 0)).EntireRow.Delete
End With

Dim LR As Long, lr2 As Long, r As Long
LR = Sheets("Swivel").Cells(Rows.Count, "A").End(xlUp).row
lr2 = Sheets("Disputed").Cells(Rows.Count, "A").End(xlUp).row
For r = LR To 2 Step -1
If Range("F" & r).Value = "Af

Solution

I don't see you using Option Explicit which is always a good idea. But you are defining your variables - which is good.

Using variable names like Row is generally a bad idea - Row already means something in excel.

The other variables LR, lr2 and r are bad names - what do they do? Why do you need two LR? I'd used SwivelLastRow and DisputedLastRow for the LR variables. The r is just a counter, so why not give it a better name? CurrentRow maybe?

I might also break the two procedures up into different subs, maybe Highlight_Disputed and CopyDisputed.

You're also using ActiveSheet.UsedRange and select which is generally something to be avoided.

The first procedure could be something like this -

Dim wsSwivel As Worksheet
   Set wsSwivel = Sheets("Swivel")
   Dim TestCell As Range
   Dim LastRow As Long
   LastRow = wsSwivel.Cells(Rows.Count, "F").End(xlUp).row
   Dim TestArea As Range
   Set TestArea = Sheets("Swivel").Range("F1:F" & LastRow)

   Dim AfterDispute As String
   AfterDispute = "After Dispute For SBU"
   Dim ImpactStatus As String
   ImpactStatus = "Impact Status"
   Dim AfterDisputeHighlight As Long
   AfterDisputeHighlight = 6

   For Each TestCell In TestArea
    If TestCell = AfterDispute Then
        TestCell.Rows.Interior.ColorIndex = AfterDisputeHighlight
        TestCell.Rows.Font.Color = RGB(255, 0, 0)
    ElseIf TestCell = ImpactStatus Then
        TestCell.Rows.Interior.Color = RGB(197, 190, 151)
        TestCell.Rows.Font.Color = RGB(0, 0, 0)
    Else:
        TestCell.Rows.Interior.ColorIndex = xlNone
        TestCell.Rows.Font.Color = RGB(0, 0, 0)
    End If
   Next


I'd also find a way to assign the RGB colors to variables so it looks cleaner.

After that you can exit sub or just CopyDisputed. Since CopyDisputed isn't returning a value, it's not a function. And since you already have some needs defined you can put in parameters:

Sub CopyDisputed(ByVal FromSwivel As Long, ByVal DisputedText As String)

And just use what you have -

CopyDisputed LastRow, AfterDispute


This eliminates the LR and one of the For Loops.

Sub CopyDisputed(ByVal FromSwivel As Long, ByVal DisputedText As String)
   Dim wsDisputed As Worksheet
   Set wsDisputed = Sheets("Disputed")
   Dim CopyRow As Long
   Dim DisputedRow As Long
   DisputedRow = 1
   wsDisputed.Range("B:Z").ClearContents

    For CopyRow = FromSwivel To 1 Step -1
        If Cells(CopyRow, "F") = DisputedText Then
           Rows(CopyRow).EntireRow.Copy Destination:=wsDisputed.Rows(DisputedRow)
           'Whoops you don't want to delete, but then why are you step -1?
           'Rows(CopyRow).EntireRow.Delete shift:=xlUp
           DisputedRow = DisputedRow + 1
        End If
    Next

End Sub


I'm assuming I understand your Disputed ws copying to be on the entire row, unless you're trying to keep column A intact?

Breaking it into two procedures makes it easier to gather what each code block is doing.

But, of course, you can avoid this if you do the copying to Disputed when you do the highlighting of the AfterDispute rows. This is something that would increase performance so you don't need to loop through column F twice:

Option Explicit

Sub Highlight_Copy_Disputed()

Application.ScreenUpdating = False

   Dim wsSwivel As Worksheet
   Set wsSwivel = Sheets("Swivel")
   Dim wsDisputed As Worksheet
   Set wsDisputed = Sheets("Disputed")
   Dim TestCell As Range
   Dim LastRow As Long
   LastRow = wsSwivel.Cells(Rows.Count, "F").End(xlUp).row
   Dim DisputedRow As Long
   DisputedRow = 1
   Dim AfterDisputeHighlight As Long
   AfterDisputeHighlight = 6

   Dim TestArea As Range
   Set TestArea = Sheets("Swivel").Range("F1:F" & LastRow)

   Dim AfterDispute As String
   AfterDispute = "After Dispute For SBU"
   Dim ImpactStatus As String
   ImpactStatus = "Impact Status"

   wsDisputed.Range("B:Z").ClearContents

   For Each TestCell In TestArea
    If TestCell = AfterDispute Then
        TestCell.Rows.Interior.ColorIndex = AfterDisputeHighlight
        TestCell.Rows.Font.Color = RGB(255, 0, 0)
        TestCell.EntireRow.Copy Destination:=wsDisputed.Rows(DisputedRow)
        DisputedRow = DisputedRow + 1
    ElseIf TestCell = ImpactStatus Then
        TestCell.Rows.Interior.Color = RGB(197, 190, 151)
        TestCell.Rows.Font.Color = RGB(0, 0, 0)
    Else:
        TestCell.Rows.Interior.ColorIndex = xlNone
        TestCell.Rows.Font.Color = RGB(0, 0, 0)
    End If
   Next
  Application.ScreenUpdating = True
End Sub

Code Snippets

Dim wsSwivel As Worksheet
   Set wsSwivel = Sheets("Swivel")
   Dim TestCell As Range
   Dim LastRow As Long
   LastRow = wsSwivel.Cells(Rows.Count, "F").End(xlUp).row
   Dim TestArea As Range
   Set TestArea = Sheets("Swivel").Range("F1:F" & LastRow)

   Dim AfterDispute As String
   AfterDispute = "After Dispute For SBU"
   Dim ImpactStatus As String
   ImpactStatus = "Impact Status"
   Dim AfterDisputeHighlight As Long
   AfterDisputeHighlight = 6


   For Each TestCell In TestArea
    If TestCell = AfterDispute Then
        TestCell.Rows.Interior.ColorIndex = AfterDisputeHighlight
        TestCell.Rows.Font.Color = RGB(255, 0, 0)
    ElseIf TestCell = ImpactStatus Then
        TestCell.Rows.Interior.Color = RGB(197, 190, 151)
        TestCell.Rows.Font.Color = RGB(0, 0, 0)
    Else:
        TestCell.Rows.Interior.ColorIndex = xlNone
        TestCell.Rows.Font.Color = RGB(0, 0, 0)
    End If
   Next
CopyDisputed LastRow, AfterDispute
Sub CopyDisputed(ByVal FromSwivel As Long, ByVal DisputedText As String)
   Dim wsDisputed As Worksheet
   Set wsDisputed = Sheets("Disputed")
   Dim CopyRow As Long
   Dim DisputedRow As Long
   DisputedRow = 1
   wsDisputed.Range("B:Z").ClearContents

    For CopyRow = FromSwivel To 1 Step -1
        If Cells(CopyRow, "F") = DisputedText Then
           Rows(CopyRow).EntireRow.Copy Destination:=wsDisputed.Rows(DisputedRow)
           'Whoops you don't want to delete, but then why are you step -1?
           'Rows(CopyRow).EntireRow.Delete shift:=xlUp
           DisputedRow = DisputedRow + 1
        End If
    Next

End Sub
Option Explicit

Sub Highlight_Copy_Disputed()

Application.ScreenUpdating = False

   Dim wsSwivel As Worksheet
   Set wsSwivel = Sheets("Swivel")
   Dim wsDisputed As Worksheet
   Set wsDisputed = Sheets("Disputed")
   Dim TestCell As Range
   Dim LastRow As Long
   LastRow = wsSwivel.Cells(Rows.Count, "F").End(xlUp).row
   Dim DisputedRow As Long
   DisputedRow = 1
   Dim AfterDisputeHighlight As Long
   AfterDisputeHighlight = 6

   Dim TestArea As Range
   Set TestArea = Sheets("Swivel").Range("F1:F" & LastRow)

   Dim AfterDispute As String
   AfterDispute = "After Dispute For SBU"
   Dim ImpactStatus As String
   ImpactStatus = "Impact Status"

   wsDisputed.Range("B:Z").ClearContents

   For Each TestCell In TestArea
    If TestCell = AfterDispute Then
        TestCell.Rows.Interior.ColorIndex = AfterDisputeHighlight
        TestCell.Rows.Font.Color = RGB(255, 0, 0)
        TestCell.EntireRow.Copy Destination:=wsDisputed.Rows(DisputedRow)
        DisputedRow = DisputedRow + 1
    ElseIf TestCell = ImpactStatus Then
        TestCell.Rows.Interior.Color = RGB(197, 190, 151)
        TestCell.Rows.Font.Color = RGB(0, 0, 0)
    Else:
        TestCell.Rows.Interior.ColorIndex = xlNone
        TestCell.Rows.Font.Color = RGB(0, 0, 0)
    End If
   Next
  Application.ScreenUpdating = True
End Sub

Context

StackExchange Code Review Q#117862, answer score: 2

Revisions (0)

No revisions yet.