Trying to speed up the calculation my For Loop

**Astroboy142** · 11-14-2010, 03:05 AM

I hope the title to my thread is sufficient.

My code below checks to see if any change occurrs between Cells L5:GR12. Am I able to speed up the calculation time in anyway? I was trying to exit my for loop but that wasn't working for me.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim iColor, TheRow As Integer
Set Shifts = Range("L5:GR12")

For Each cell In Shifts
  Select Case cell.Value
    Case "D"
      iColor = 7                    'Pink
      cell.Font.ColorIndex = 1      'Black
      Select Case cell.Row
         Case 5
            Sheets("Audit~Jan-Jun").Cells(200, cell.Column - 8).ClearContents
            Sheets("Audit~Jan-Jun").Cells(201, cell.Column - 8).ClearContents
            Sheets("Audit~Jan-Jun").Cells(202, cell.Column - 8).ClearContents
            Sheets("Audit~Jan-Jun").Cells(203, cell.Column - 8).ClearContents
      End Select
    Case "N"
      iColor = 4                    'Green
      cell.Font.ColorIndex = 1      'Black
    Case "S", "S10"
      iColor = 42                   'Turquoise
      cell.Font.ColorIndex = 1      'Black
    Case "V", "V8", "V10", "V12", "H8", "H10", "H12", "E8", "E12"
      iColor = 40                   'Tan
      cell.Font.ColorIndex = 1      'Black
    Case "SH"
      iColor = 24                   'Ice Blue
      cell.Font.ColorIndex = 3      'Red
    Case "SD4", "SD5", "SD6", "SD7", "SD8", "SD9"
      iColor = 27                   'Yellow
      cell.Font.ColorIndex = 1      'Black
    Case "SD10", "SD11", "SD12", "SD13", "SD14", "SD15"
      iColor = 27                   'Yellow
      cell.Font.ColorIndex = 1      'Black
    Case Else
      iColor = 2                    'White
      cell.Font.ColorIndex = 1      'Black
  End Select
      cell.Interior.ColorIndex = iColor
Next
End Sub

**DonkeyOte** · 11-14-2010, 03:51 AM

In reality the Change Event is pref. to the Calculate Event because if offers Target - ie we know which cell(s) have been modified.

From the Target we should in turn be able to deduce which cell(s) [if any] require updating via the Change Event itself.

To determine the above we need to know the formulae contained within L5:GR12 [if any]

Also, do you have a Change Event in place on "Audit-Jan-Jun" sheet ?

**Astroboy142** · 11-14-2010, 06:57 PM

Hi DonkeyOTE,

Thanks for the reply. In range L5:GR12, no formula is present. A user would enter either a D, N, S, S10, etc in those cells. Depending on the entry the change event would color that cell.

Further, there is no change event occurring in the "Audit~Jan-Jun" sheet. A command button enters the values in that sheet only when called upon.

I changed my code and it works better with the exception for one thing. If I select a group of cells within L5:GR15 and hit deleted then I get a run time error 13. Any idea how to get around this one?

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim iColor As Integer
    
    If Not Intersect(Target, Range("L5:GR12")) Is Nothing Then          'Changes the colour of each cell in the range of L5:GR12 ONLY
      Select Case Target.Value
        Case "D"
          iColor = 7                        'Pink
          Target.Font.ColorIndex = 1        'Black
          Call ClearVacationAudit(Target)
        Case "N"
          iColor = 4                        'Green
          Target.Font.ColorIndex = 1        'Black
          Call ClearVacationAudit(Target)
        Case "S", "S10"
          iColor = 42                       'Turquoise
          Target.Font.ColorIndex = 1        'Black
          Call ClearVacationAudit(Target)
        
        Case "V"
          iColor = 40                       'Tan
          Target.Font.ColorIndex = 1        'Black
        
        Case "SH"
          iColor = 24                       'Ice Blue
          Target.Font.ColorIndex = 3        'Red
          Call ClearVacationAudit(Target)
        Case "SD4", "SD5", "SD6", "SD7", "SD8", "SD9"
          iColor = 27                       'Yellow
          Target.Font.ColorIndex = 1        'Black
          Call ClearVacationAudit(Target)
        Case "SD10", "SD11", "SD12", "SD13", "SD14", "SD15"
          iColor = 27                       'Yellow
          Target.Font.ColorIndex = 1        'Black
          Call ClearVacationAudit(Target)
        Case "O", ""
          iColor = 2                        'White
          Target.Font.ColorIndex = 1        'Black
          Call ClearVacationAudit(Target)
      End Select
          Target.Interior.ColorIndex = iColor
    End If
End Sub
Sub ClearVacationAudit(Target)
  Dim TheRow As Integer
  
  Select Case Target.Row
    Case 5                              'Clear Vacation Hours for SSC1
      For TheRow = 200 To 203
        Sheets("Audit~Jan-Jun").Cells(TheRow, Target.Column - 8).ClearContents
      Next
    Case 6                              'Clear Vacation Hours for SSC2
      For TheRow = 206 To 209
        Sheets("Audit~Jan-Jun").Cells(TheRow, Target.Column - 8).ClearContents
      Next
    Case 7                              'Clear Vacation Hours for SSC3
      For TheRow = 212 To 215
        Sheets("Audit~Jan-Jun").Cells(TheRow, Target.Column - 8).ClearContents
      Next
    Case 8                              'Clear Vacation Hours for SSC4
      For TheRow = 218 To 221
        Sheets("Audit~Jan-Jun").Cells(TheRow, Target.Column - 8).ClearContents
      Next
    Case 9                              'Clear Vacation Hours for SSC5
      For TheRow = 224 To 227
        Sheets("Audit~Jan-Jun").Cells(TheRow, Target.Column - 8).ClearContents
      Next
    Case 10                              'Clear Vacation Hours for SSC6
      For TheRow = 230 To 233
        Sheets("Audit~Jan-Jun").Cells(TheRow, Target.Column - 8).ClearContents
      Next
    Case 11                              'Clear Vacation Hours for SSC7
      For TheRow = 236 To 239
        Sheets("Audit~Jan-Jun").Cells(TheRow, Target.Column - 8).ClearContents
      Next
    Case 12                              'Clear Vacation Hours for SSC8
      For TheRow = 242 To 245
        Sheets("Audit~Jan-Jun").Cells(TheRow, Target.Column - 8).ClearContents
      Next
  End Select
End Sub

**DonkeyOte** · 11-15-2010, 04:32 AM

Without looking too deeply - perhaps try revising along the lines of:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngInterest As Range, rngCell As Range
    Dim iColor As Long, fColor As Long
    Set rngInterest = Intersect(Target, Range("L5:GR12"))
    If Not rngInterest Is Nothing Then
        For Each rngCell In rngInterest.Cells
            Select Case rngCell.Value
                Case "D"
                    iColor = 7                        'Pink
                    fColor = 1                        'Black
                Case "N"
                    iColor = 4                        'Green
                    fColor = 1                        'Black
                Case "S", "S10"
                    iColor = 42                       'Turquoise
                    fColor = 1                        'Black
                Case "V"
                    iColor = 40                       'Tan
                    fColor = 1                        'Black
                Case "SH"
                    iColor = 24                       'Ice Blue
                    fColor = 3                        'Red
                Case "SD4", "SD5", "SD6", "SD7", "SD8", "SD9"
                    iColor = 27                       'Yellow
                    fColor = 1                        'Black
                Case "SD10", "SD11", "SD12", "SD13", "SD14", "SD15"
                    iColor = 27                       'Yellow
                    fColor = 1                        'Black
                Case "O", ""
                    iColor = 2                        'White
                    fColor = 1                        'Black
                Case Else
                    iColor = -1
            End Select
            If iColor <> -1 Then
                With rngCell
                    .Interior.ColorIndex = iColor
                    .Font.ColorIndex = fColor
                End With
                Call ClearVacationAudit(rngCell)
            End If
        Next rngCell
    End If
    Set rngInterest = Nothing
End Sub

Sub ClearVacationAudit(rngCell As Range)
    Select Case rngCell.Row
        Case 5 To 12
            Sheets("Audit~Jan~Jun").Cells(200 + 6 * (rngCell.Row - 5), rngCell.Column - 8).Resize(4).ClearContents
    End Select
End Sub