4
\$\begingroup\$

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 = "After Dispute For SBU" Then
            Rows(r).Copy Destination:=Sheets("Disputed").Range("A" & lr2 + 1)
            lr2 = Sheets("Disputed").Cells(Rows.Count, "A").End(xlUp).row
        End If

        Range("A2").Select
    Next r
Application.ScreenUpdating = True
    Range("C" & Rows.Count).End(xlUp).Offset(1).Select
End Sub
\$\endgroup\$
1
  • \$\begingroup\$ Erratic cursor behaviour is unusual because you've got screenupdating off. Are there any events that trigger on workbook/sheet change? Have you tried setting enableEvents to false and seeing if that solves the cursor problem? \$\endgroup\$
    – Kaz
    Jan 26, 2016 at 13:33

1 Answer 1

2
\$\begingroup\$

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
\$\endgroup\$
3
  • \$\begingroup\$ @Rastafarian There are two things that I did not mention above. 1) This code is in a module that has Option Explicit at the top. 2) The second part of the code will delete all data on the Disputed worksheet before pasting the new data from the Swivel Worksheet. This was put in place because on rare occasions the impact code will change which changes the status of that row of data and may remove it. Plus, we were also seeing duplicates of the data in the Disputed worksheet. \$\endgroup\$
    – Iron Man
    Jan 26, 2016 at 15:11
  • \$\begingroup\$ Either way a simple Sheets("Disputed").Range("B:Z").clearcontents anywhere should clear that out, right? \$\endgroup\$ Jan 26, 2016 at 15:17
  • \$\begingroup\$ Thank you. This has improved the performance all around. It also taught me a few things about VBA, which is always good. \$\endgroup\$
    – Iron Man
    Jan 26, 2016 at 15:47

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.