• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1228
  • Last Modified:

Infinite Loop Problem With Excel VBA

I've pieced together some VBA to format a range in Excel.  However, when I remove Application.ScreenUpdating = False, the spreadsheet loops forever.

I think it may be related to nesting a With statement inside an If statement which is inside a Case statement.  Too many nested loops?

I've attached the Excel file I'm using (macro) and posted the code.


Private Sub Worksheet_Calculate()
'Range("M9:BJ9").ClearContents
    Dim thing As Range
    Const xlColorIndexNone = -4142
    
    With Application
        .CellDragAndDrop = False
        .CutCopyMode = False
        .EnableEvents = False
        .ScreenUpdating = False
        .EnableCancelKey = xlDisabled
   End With
    Call GanttChartArea
    For Each thing In Range("M9:BJ9")
        Select Case Application.Weekday(thing.Value)
            Case 1
                thing.Offset(1, 0).Value = "Su"
                thing.Offset(1, 0).Interior.Color = RGB(214, 214, 214)
                Call WeekendFormat(thing)
            Case 2
                thing.Offset(1, 0).Value = "M"
                Call WeekdayFormat(thing)
            Case 3
                thing.Offset(1, 0).Value = "T"
                Call WeekdayFormat(thing)
            Case 4
                thing.Offset(1, 0).Value = "W"
                Call WeekdayFormat(thing)
            Case 5
                thing.Offset(1, 0).Value = "Th"
                Call WeekdayFormat(thing)
            Case 6
                thing.Offset(1, 0).Value = "F"
                Call WeekdayFormat(thing)
            Case 7
                thing.Offset(1, 0).Value = "Sa"
                thing.Offset(1, 0).Interior.Color = RGB(214, 214, 214) '159,182,205
                Call WeekendFormat(thing)
        End Select
    Next
   Application.EnableCancelKey = xlInterrupt
End Sub
 
Private Sub GanttChartArea()
Dim ganttChart As Range
Set ganttChart = Range("M11:BJ38")
        ganttChart.Interior.Color = RGB(0, 0, 0)
End Sub
Private Sub WeekdayFormat(ByRef thing As Range)
    thing.Interior.ColorIndex = xlColorIndexNone
    For i = 1 To 1
        With thing.Offset(i, 0)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Name = "Calibri"
            .Font.FontStyle = "Regular"
            .Font.Size = 10
            .Interior.ColorIndex = xlColorIndexNone
        End With
    Next i
    
End Sub
Private Sub WeekendFormat(ByRef thing As Range)
    'apply format to gantt chart area
    'http://cloford.com/resources/colours/500col.htm
    'http://web.njit.edu/~kevin/rgb.txt.html
    'http://www.tayloredmktg.com/rgb/#BL
    Const xlColorIndexNone = -4142
    For i = 2 To 29
        With thing.Offset(i, 0)
            .Rows.AutoFit
            .Columns.AutoFit
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Name = "Calibri"
            .Font.FontStyle = "Regular"
            .Font.Size = 10
            .Interior.Color = RGB(0, 0, 0) '25, 25, 112
         End With
        If Application.Weekday(thing.Value) <> 1 Or Application.Weekday(thing.Value) <> 7 Then
            'remove borders from weekdays
            With thing.Offset(i, 0)
                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).LineStyle = xlNone
                .Borders(xlEdgeTop).LineStyle = xlNone
                .Borders(xlEdgeBottom).LineStyle = xlNone
                .Borders(xlEdgeRight).LineStyle = xlNone
                .Borders(xlInsideVertical).LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
            End With
        End If
        If Application.Weekday(thing.Value) = 1 Then
            'apply right border to Sun
            With thing.Offset(i, 0)
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlEdgeRight).Weight = xlThin
                .Borders(xlEdgeRight).Color = RGB(85, 85, 85)
            End With
        End If
        If Application.Weekday(thing.Value) = 7 Then
            'apply left border to Sat
            With thing.Offset(i, 0)
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeLeft).Weight = xlThin
                .Borders(xlEdgeLeft).Color = RGB(85, 85, 85)
            End With
        End If
 
    Next i
End Sub

Open in new window

MyExample.xls
0
UserName01100001
Asked:
UserName01100001
  • 8
  • 6
  • 4
  • +1
1 Solution
 
GRayLCommented:
Isn't a Cell in a Range?  ie. Dim Thing as Cell
0
 
Saurabh Singh TeotiaCommented:
Hi,
I just run the code both with screenupdating to true and then removing that line, the only difference i see the time that it takes post removing this line is compartively higher then when you have that line, reason for the same is when applicaion.screenupdating=false, makes the macro run faster compare when you remove it.
And anyways you are code is working fine so why do you want to remove it.. as that command prevents flickering of screen when the macro is running...
Saurabh...
0
 
UserName01100001Author Commented:
GRayL,

Declaring the "thing" as cell results in a Compile error.  User-defined type not defined.
0
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 
Saurabh Singh TeotiaCommented:
what greyl meant is declaring that as range that is
dim thing as range but again like i said it wont make much of difference since time consumed is directly dependent over how you run the macro, your code doesnt get struck in infinite code, it still does and complete itself, its just that the time it takes is compartively higher then what it is earlier...
0
 
UserName01100001Author Commented:
saurabh726,

When that line is not commented out, the text fields (M10:BJ10) under the row of dates (M9:BJ9) do not update when the start date (H2) is changed.  Otherwise I would leave it.
0
 
Saurabh Singh TeotiaCommented:
See that line doesnt plays any role in the way you macro functions, Since that line is only to stop flickering of the screen, it doesnt play any role in the functionality of your code...if something is not working then its not because of that line since it got nothing to do with it...
0
 
UserName01100001Author Commented:
Do you notice that row not tracking with the date row?  I thought it was related to this, but apparently not.
0
 
Saurabh Singh TeotiaCommented:
I didnt investigated your code further as to do that i'm going to take a sufficent time since the manner its written, but having said that, the line that you are refering to has nothing to do with any functionality like i already clarified...
0
 
UserName01100001Author Commented:
When I change the date in cell H2, the abbreviated day (Su,M,T,W,Th,F,Sa) does not change with it.
0
 
Nate_OliverCommented:
Hello,

You can't declare anything as a Cell, which is actually a property.

Are you sure you didn't remove this?

>        .EnableEvents = False

That would be a problem. And you should reset everything the original With Statement does with True at the end of your first procedure. Just copy and paste it and flip False to True, except for xlDisabled.
0
 
Nate_OliverCommented:
Hello,

>When I change the date in cell H2, the abbreviated day (Su,M,T,W,Th,F,Sa) does not change with it.

Then you're using the wrong event, you want a Worksheet_Change event - there's an example, here:

http://www.cpearson.com/excel/Events.aspx

The reason you want want to toggle EnableEvents, is that every time you populate a cell you recall the Calc event - which is not what you want, as Chip notes, see "Order of Events".
0
 
UserName01100001Author Commented:
Nate Oliver,

I tried turning those items in the With statement to True.  However, I still get a loop effect when changing the date in cell H2.



With Application
        .CellDragAndDrop = True
        .CutCopyMode = True
        .EnableEvents = True
        .ScreenUpdating = True
        .EnableCancelKey = xlDisabled
End With

Open in new window

0
 
Nate_OliverCommented:
Hello,

Repost your code - you want to set it False in the beginning, and True at the end of your first procedure.
0
 
Nate_OliverCommented:
Like this. *untested*
Private Sub Worksheet_Calculate()
'Range("M9:BJ9").ClearContents
    Dim thing As Range
    Const xlColorIndexNone = -4142
    
    With Application
        .CutCopyMode = False
        .EnableEvents = False
        .ScreenUpdating = False
        .EnableCancelKey = xlDisabled
   End With
    Call GanttChartArea
    For Each thing In Range("M9:BJ9")
        Select Case Application.Weekday(thing.Value)
            Case 1
                thing.Offset(1, 0).Value = "Su"
                thing.Offset(1, 0).Interior.Color = RGB(214, 214, 214)
                Call WeekendFormat(thing)
            Case 2
                thing.Offset(1, 0).Value = "M"
                Call WeekdayFormat(thing)
            Case 3
                thing.Offset(1, 0).Value = "T"
                Call WeekdayFormat(thing)
            Case 4
                thing.Offset(1, 0).Value = "W"
                Call WeekdayFormat(thing)
            Case 5
                thing.Offset(1, 0).Value = "Th"
                Call WeekdayFormat(thing)
            Case 6
                thing.Offset(1, 0).Value = "F"
                Call WeekdayFormat(thing)
            Case 7
                thing.Offset(1, 0).Value = "Sa"
                thing.Offset(1, 0).Interior.Color = RGB(214, 214, 214) '159,182,205
                Call WeekendFormat(thing)
        End Select
    Next
 
With Application
    .CellDragAndDrop = True
    .EnableEvents = True
    .ScreenUpdating = True
    .EnableCancelKey = xlInterrupt
End With
End Sub

Open in new window

0
 
UserName01100001Author Commented:
Like this?

 
Private Sub Worksheet_Change(ByVal Target As Range)
   
End Sub
Private Sub Worksheet_Calculate()
'Range("M9:BJ9").ClearContents
    Dim thing As Range
    Const xlColorIndexNone = -4142
    
    With Application
        .CellDragAndDrop = True
        .CutCopyMode = True
        .EnableEvents = True
        .ScreenUpdating = True
        .EnableCancelKey = xlDisabled
        '.CellDragAndDrop = False
        '.CutCopyMode = False
        '.EnableEvents = False
        '.ScreenUpdating = False
        '.EnableCancelKey = xlDisabled
   End With
    Call GanttChartArea
    For Each thing In Range("M9:BJ9")
        Select Case Application.Weekday(thing.Value)
            Case 1
                thing.Offset(1, 0).Value = "Su"
                thing.Offset(1, 0).Interior.Color = RGB(214, 214, 214)
                Call WeekendFormat(thing)
            Case 2
                thing.Offset(1, 0).Value = "M"
                Call WeekdayFormat(thing)
            Case 3
                thing.Offset(1, 0).Value = "T"
                Call WeekdayFormat(thing)
            Case 4
                thing.Offset(1, 0).Value = "W"
                Call WeekdayFormat(thing)
            Case 5
                thing.Offset(1, 0).Value = "Th"
                Call WeekdayFormat(thing)
            Case 6
                thing.Offset(1, 0).Value = "F"
                Call WeekdayFormat(thing)
            Case 7
                thing.Offset(1, 0).Value = "Sa"
                thing.Offset(1, 0).Interior.Color = RGB(214, 214, 214) '159,182,205
                Call WeekendFormat(thing)
        End Select
    Next
   Application.EnableCancelKey = xlInterrupt
   
    With Application
        .CellDragAndDrop = False
        .CutCopyMode = False
        .EnableEvents = False
        .ScreenUpdating = False
        .EnableCancelKey = xlDisabled
        End With
End Sub
 
Private Sub GanttChartArea()
Dim ganttChart As Range
Set ganttChart = Range("M11:BJ38")
        ganttChart.Interior.Color = RGB(0, 0, 0)
End Sub
Private Sub WeekdayFormat(ByRef thing As Range)
    thing.Interior.ColorIndex = xlColorIndexNone
    For i = 1 To 1
        With thing.Offset(i, 0)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Name = "Calibri"
            .Font.FontStyle = "Regular"
            .Font.Size = 10
            .Interior.ColorIndex = xlColorIndexNone
        End With
    Next i
    
End Sub
Private Sub WeekendFormat(ByRef thing As Range)
    'apply format to gantt chart area
    'http://cloford.com/resources/colours/500col.htm
    'http://web.njit.edu/~kevin/rgb.txt.html
    'http://www.tayloredmktg.com/rgb/#BL
    Const xlColorIndexNone = -4142
    For i = 2 To 29
        With thing.Offset(i, 0)
            .Rows.AutoFit
            .Columns.AutoFit
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Name = "Calibri"
            .Font.FontStyle = "Regular"
            .Font.Size = 10
            .Interior.Color = RGB(0, 0, 0) '25, 25, 112
         End With
        If Application.Weekday(thing.Value) <> 1 Or Application.Weekday(thing.Value) <> 7 Then
            'remove borders from weekdays
            With thing.Offset(i, 0)
                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlEdgeLeft).LineStyle = xlNone
                .Borders(xlEdgeTop).LineStyle = xlNone
                .Borders(xlEdgeBottom).LineStyle = xlNone
                .Borders(xlEdgeRight).LineStyle = xlNone
                .Borders(xlInsideVertical).LineStyle = xlNone
                .Borders(xlInsideHorizontal).LineStyle = xlNone
            End With
        End If
        If Application.Weekday(thing.Value) = 1 Then
            'apply right border to Sun
            With thing.Offset(i, 0)
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlEdgeRight).Weight = xlThin
                .Borders(xlEdgeRight).Color = RGB(85, 85, 85)
            End With
        End If
        If Application.Weekday(thing.Value) = 7 Then
            'apply left border to Sat
            With thing.Offset(i, 0)
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeLeft).Weight = xlThin
                .Borders(xlEdgeLeft).Color = RGB(85, 85, 85)
            End With
        End If
 
    Next i
End Sub
 
Sub HiLiteWeekends()
    Worksheet_Calculate
End Sub
 
Private Sub xlVariables()
   MsgBox xlNone ' -4142
   MsgBox xlContinuous ' 1
   MsgBox xlMedium ' -4138
   MsgBox xlAutomatic ' -4105
   MsgBox xlDiagonalDown ' 5
   MsgBox xlDiagonalUp ' 6
   MsgBox xlEdgeLeft ' 7
   MsgBox xlEdgeTop ' 8
   MsgBox xlEdgeBottom ' 9
   MsgBox xlEdgeRight ' 10
   MsgBox xlInsideVertical ' 11
   MsgBox xlInsideHorizontal ' 12
   MsgBox xlDistributed ' -4117
   MsgBox xlCenter ' -4108
End Sub

Open in new window

0
 
UserName01100001Author Commented:
whoops, mines backwards....
0
 
Nate_OliverCommented:
Right, go False in the beginning and reset to True in the end.
0
 
UserName01100001Author Commented:
PERFECT!
Thank you Nate_Oliver!!  That worked.
0
 
Nate_OliverCommented:
You are welcome! :)
0

Featured Post

NFR key for Veeam Backup for Microsoft Office 365

Veeam is happy to provide a free NFR license (for 1 year, up to 10 users). This license allows for the non‑production use of Veeam Backup for Microsoft Office 365 in your home lab without any feature limitations.

  • 8
  • 6
  • 4
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now