VBA code runs too slow

I

ioncila

New Member
Joined
Mar 18, 2009
Messages
4
Hi
I´m very very new in vba and i´ve made this code to run a sort of gantt chart for some projects of my own. But this macro takes about 5 minutes to run. I've search on the web for faster methods but no luck. I think the problem is in the syntax of the code. So i wish i could get some help. Thank you very much. I use Excel 2003.

Here's the code:


'EXECUTAR GRÁFICO GANTT
Sub GanttChart()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim ws As Worksheet
Set ws = Worksheets("PT Geral1463d")

'Gráfico Gantt
ws.Range("O21:HN494").Select
With Selection
Interior.ColorIndex = xlNone
Borders(xlDiagonalDown).LineStyle = xlNone
Borders(xlDiagonalUp).LineStyle = xlNone
Borders(xlEdgeTop).LineStyle = xlNone
Borders(xlEdgeBottom).LineStyle = xlNone
Borders(xlInsideHorizontal).LineStyle = xlNone
End With

Dim i As Integer
Dim c As Integer
Dim Sdate As Date
Dim Edate As Date

For i = 21 To 494
For c = 15 To 222

If Cells(i, 4).Value > 0 And (Cells(5, c).Value >= Cells(i, 10).Value Or _
Cells(6, c).Value >= Cells(i, 10).Value Or _
Cells(7, c).Value >= Cells(i, 10).Value Or _
Cells(8, c).Value >= Cells(i, 10).Value Or _
Cells(9, c).Value >= Cells(i, 10).Value Or _
Cells(10, c).Value >= Cells(i, 10).Value Or _
Cells(11, c).Value >= Cells(i, 10).Value) And (Cells(5, c).Value <= Cells(i, 11).Value Or _
Cells(6, c).Value <= Cells(i, 11).Value Or _
Cells(7, c).Value <= Cells(i, 11).Value Or _
Cells(8, c).Value <= Cells(i, 11).Value Or _
Cells(9, c).Value <= Cells(i, 11).Value Or _
Cells(10, c).Value <= Cells(i, 11).Value Or _
Cells(11, c).Value <= Cells(i, 11).Value) Then

Select Case Cells(i, 4)
Case 1
Cells(i, 4) = 1
Cells(i, c).Interior.ColorIndex = 11
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 11
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 11
.Weight = xlThin
End With
With Cells(i, c).Characters.Font
.ColorIndex = 11
End With
Case 2
Cells(i, 4) = 2
Cells(i, c).Interior.ColorIndex = 41
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 41
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 41
.Weight = xlThin
End With
With Cells(i, c).Characters.Font
.ColorIndex = 41
End With
Case 3
Cells(i, 4) = 3
Cells(i, c).Interior.ColorIndex = 37
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 37
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 37
.Weight = xlThin
End With
With Cells(i, c).Characters.Font
.ColorIndex = 37
End With
Case 4
Cells(i, 4) = 4
Cells(i, c).Interior.ColorIndex = 24
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 24
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 24
.Weight = xlThin
End With
With Cells(i, c).Characters.Font
.ColorIndex = 24
End With
End Select
End If
Next c
Next i

'Equipamento
ws.Range("O503:HN689").Select
With Selection
Interior.ColorIndex = xlNone
Borders(xlDiagonalDown).LineStyle = xlNone
Borders(xlDiagonalUp).LineStyle = xlNone
Borders(xlEdgeTop).LineStyle = xlNone
Borders(xlEdgeBottom).LineStyle = xlNone
Borders(xlInsideHorizontal).LineStyle = xlNone
End With

For i = 503 To 689
For c = 15 To 222

If Cells(i, 4).Value > 0 And (Cells(5, c).Value >= Cells(i, 10).Value Or _
Cells(6, c).Value >= Cells(i, 10).Value Or _
Cells(7, c).Value >= Cells(i, 10).Value Or _
Cells(8, c).Value >= Cells(i, 10).Value Or _
Cells(9, c).Value >= Cells(i, 10).Value Or _
Cells(10, c).Value >= Cells(i, 10).Value Or _
Cells(11, c).Value >= Cells(i, 10).Value) And (Cells(5, c).Value <= Cells(i, 11).Value Or _
Cells(6, c).Value <= Cells(i, 11).Value Or _
Cells(7, c).Value <= Cells(i, 11).Value Or _
Cells(8, c).Value <= Cells(i, 11).Value Or _
Cells(9, c).Value <= Cells(i, 11).Value Or _
Cells(10, c).Value <= Cells(i, 11).Value Or _
Cells(11, c).Value <= Cells(i, 11).Value) Then

Select Case Cells(i, 4)
Case 1
Cells(i, 4) = 1
Cells(i, c).Interior.ColorIndex = 11
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 11
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 11
.Weight = xlThin
End With
Case 2
Cells(i, 4) = 2
Cells(i, c).Interior.ColorIndex = 41
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 41
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 41
.Weight = xlThin
End With
Case 3
Cells(i, 4) = 3
Cells(i, c).Interior.ColorIndex = 37
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 37
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 37
.Weight = xlThin
End With
Case 4
Cells(i, 4) = 4
Cells(i, c).Interior.ColorIndex = 24
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 24
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 24
.Weight = xlThin
End With
'With Cells(i, c).Characters.Font
'.ColorIndex = 24
'End With
End Select
End If
Next c
Next i

'Mão de Obra
ws.Range("O692:HN717").Select
With Selection
Interior.ColorIndex = xlNone
Borders(xlDiagonalDown).LineStyle = xlNone
Borders(xlDiagonalUp).LineStyle = xlNone
Borders(xlEdgeTop).LineStyle = xlNone
Borders(xlEdgeBottom).LineStyle = xlNone
Borders(xlInsideHorizontal).LineStyle = xlNone
End With

For i = 692 To 717
For c = 15 To 222

If Cells(i, 4).Value > 0 And (Cells(5, c).Value >= Cells(i, 10).Value Or _
Cells(6, c).Value >= Cells(i, 10).Value Or _
Cells(7, c).Value >= Cells(i, 10).Value Or _
Cells(8, c).Value >= Cells(i, 10).Value Or _
Cells(9, c).Value >= Cells(i, 10).Value Or _
Cells(10, c).Value >= Cells(i, 10).Value Or _
Cells(11, c).Value >= Cells(i, 10).Value) And (Cells(5, c).Value <= Cells(i, 11).Value Or _
Cells(6, c).Value <= Cells(i, 11).Value Or _
Cells(7, c).Value <= Cells(i, 11).Value Or _
Cells(8, c).Value <= Cells(i, 11).Value Or _
Cells(9, c).Value <= Cells(i, 11).Value Or _
Cells(10, c).Value <= Cells(i, 11).Value Or _
Cells(11, c).Value <= Cells(i, 11).Value) Then

Select Case Cells(i, 4)
Case 1
Cells(i, 4) = 1
Cells(i, c).Interior.ColorIndex = 11
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 11
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 11
.Weight = xlThin
End With
Case 2
Cells(i, 4) = 2
Cells(i, c).Interior.ColorIndex = 41
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 41
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 41
.Weight = xlThin
End With
Case 3
Cells(i, 4) = 3
Cells(i, c).Interior.ColorIndex = 37
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 37
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 37
.Weight = xlThin
End With
Case 4
Cells(i, 4) = 4
Cells(i, c).Interior.ColorIndex = 24
With Cells(i, c).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With Cells(i, c).Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 24
.Weight = xlThin
End With
With Cells(i, c).Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 24
.Weight = xlThin
End With

End Select
End If
Next c
Next i

Set ws = Nothing

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub </pre>
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Sort by date Sort by votes
you can put break points at the start of each part (section) of the code to find out which parts are slow

this part
For i = 21 To 494
For c = 15 To 222

If Cells(i, 4).Value > 0 And (Cells(5, c).Value >= Cells(i, 10).Value Or _
Cells(6, c).Value >= Cells(i, 10).Value Or _
Cells(7, c).Value >= Cells(i, 10).Value Or _
Cells(8, c).Value >= Cells(i, 10).Value Or _
Cells(9, c).Value >= Cells(i, 10).Value Or _
Cells(10, c).Value >= Cells(i, 10).Value Or _
Cells(11, c).Value >= Cells(i, 10).Value) And (Cells(5, c).Value <= Cells(i, 11).Value Or _
Cells(6, c).Value <= Cells(i, 11).Value Or _
Cells(7, c).Value <= Cells(i, 11).Value Or _
Cells(8, c).Value <= Cells(i, 11).Value Or _
Cells(9, c).Value <= Cells(i, 11).Value Or _
Cells(10, c).Value <= Cells(i, 11).Value Or _
Cells(11, c).Value <= Cells(i, 11).Value) Then
Click to expand...
looks like the culprit as it has to evaluate every condition even if the first is false
if you can break this into multiple conditional statements it may increase speed, if first if is false, no more are evaluated

also you are using multiple with blocks for the same cell (each border) probably quicker to use 1 with block for the cell the set all borders for the cell

Select Case Cells(i, 4)
Case 1
Cells(i, 4) = 1
Click to expand...
the last line appears to be redundant, the cell must already be 1 for that case to run, not that it will make any difference to speed
 
Last edited:
Upvote 0
There is a large overhead in selecting, reading or writing an Excel cell from VBA.
Therefore it is generally much quicker to read a large range into a variant, process it and write it back: I have rewritten the first block (not tested)

Sub GanttChart()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim ws As Worksheet
Set ws = Worksheets("PT Geral1463d")
Dim vBlock1 As Variant
Dim oRng As Range
Dim oCase1 As Range
Dim oCase2 As Range
Dim oCase3 As Range
Dim oCase4 As Range

Dim i As Long
Dim c As Long
Dim Sdate As Date
Dim Edate As Date

'Gráfico Gantt

Set oRng = ws.Range("O21:HN494")
With oRng
.Interior.ColorIndex = xlNone
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

vBlock1 = oRng.Value2

For c = 1 To 208
For i = 1 To 474

If vBlock1(i, 4) > 0 And (vBlock1(5, c) >= vBlock1(i, 10) Or _
vBlock1(6, c) >= vBlock1(i, 10) Or _
vBlock1(7, c) >= vBlock1(i, 10) Or _
vBlock1(8, c) >= vBlock1(i, 10) Or _
vBlock1(9, c) >= vBlock1(i, 10) Or _
vBlock1(10, c) >= vBlock1(i, 10) Or _
vBlock1(11, c) >= vBlock1(i, 10)) And (vBlock1(5, c) <= vBlock1(i, 11) Or _
vBlock1(6, c) <= vBlock1(i, 11) Or _
vBlock1(7, c) <= vBlock1(i, 11) Or _
vBlock1(8, c) <= vBlock1(i, 11) Or _
vBlock1(9, c) <= vBlock1(i, 11) Or _
vBlock1(10, c) <= vBlock1(i, 11) Or _
vBlock1(11, c) <= vBlock1(i, 11)) Then

Select Case vBlock1(i, 4)
Case 1
If oCase1 Is Nothing Then
Set oCase1 = oRng.Cells(i, c)
Else
Set oCase1 = Union(oCase1, oRng.Cells(i, c))
End If

Case 2
If oCase2 Is Nothing Then
Set oCase2 = oRng.Cells(i, c)
Else
Set oCase2 = Union(oCase2, oRng.Cells(i, c))
End If

Case 3
If oCase3 Is Nothing Then
Set oCase3 = oRng.Cells(i, c)
Else
Set oCase3 = Union(oCase3, oRng.Cells(i, c))
End If

Case 4
If oCase4 Is Nothing Then
Set oCase4 = oRng.Cells(i, c)
Else
Set oCase4 = Union(oCase4, oRng.Cells(i, c))
End If

End Select
End If
Next i
Next c

If Not oCase1 Is Nothing Then
oCase1.Interior.ColorIndex = 11
With oCase1.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With oCase1.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With oCase1.Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 11
.Weight = xlThin
End With
With oCase1.Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 11
.Weight = xlThin
End With
With oCase1.Characters.Font
.ColorIndex = 11
End With
End If

If Not oCase2 Is Nothing Then
oCase2.Interior.ColorIndex = 41
With oCase2.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With oCase2.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With oCase2.Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 41
.Weight = xlThin
End With
With oCase2.Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 41
.Weight = xlThin
End With
With oCase2.Characters.Font
.ColorIndex = 41
End With
End If

If Not oCase3 Is Nothing Then
oCase3.Interior.ColorIndex = 37
With oCase3.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With oCase3.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With oCase3.Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 37
.Weight = xlThin
End With
With oCase3.Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 37
.Weight = xlThin
End With
With oCase3.Characters.Font
.ColorIndex = 37
End With
End If

If Not oCase4 Is Nothing Then
oCase4.Interior.ColorIndex = 24
With oCase4.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With oCase4.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 2
.Weight = xlThick
End With
With oCase4.Borders(xlRight)
.LineStyle = xlContinuous
.ColorIndex = 24
.Weight = xlThin
End With
With oCase4.Borders(xlLeft)
.LineStyle = xlContinuous
.ColorIndex = 24
.Weight = xlThin
End With
With oCase4.Characters.Font
.ColorIndex = 24
End With
End If


Set ws = Nothing

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub
 
Upvote 0
After studying yours and other suggestions i've rewriten the code and made it run in about 34 seconds, which is a very good increase of speed (more then 4 minutes in the beginning). How ever its still very slow.

@WESTCONN1
I took your suggestions on rewriting this new code. Thank you very much for that.

@FASTEXCEL
Your code is really really fast (less than one second to execute) and that's the speed I would like to increase to my macro. But when I run your code, nothing happens (it only clears the formats but doesnt update new values). Thats a pity.

So, I wish you could look another time for the code and figure whats wrong, I'd be thankful. Thanks.

Here's the new code:

'EXECUTAR GRÁFICO GANTT
Sub GanttChart()
Start = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim i As Integer, c As Integer
Dim ws As Worksheet
Set ws = Worksheets("PT Geral1463d")

'Gráfico Gantt
'This is to clear bar formats in the range
ws.Range("O21:HN494").Select
With Selection
.Interior.ColorIndex = xlNone
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 37
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 37
.Borders(xlLeft).Weight = xlThin
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

For i = 21 To 494
For c = 15 To 222

If Cells(i, 4).Value = 0 Then
On Error Resume Next
ElseIf (Cells(5, c).Value >= Cells(i, 10).Value Or _
Cells(6, c).Value >= Cells(i, 10).Value Or _
Cells(7, c).Value >= Cells(i, 10).Value Or _
Cells(8, c).Value >= Cells(i, 10).Value Or _
Cells(9, c).Value >= Cells(i, 10).Value Or _
Cells(10, c).Value >= Cells(i, 10).Value Or _
Cells(11, c).Value >= Cells(i, 10).Value) And (Cells(5, c).Value <= Cells(i, 11).Value Or _
Cells(6, c).Value <= Cells(i, 11).Value Or _
Cells(7, c).Value <= Cells(i, 11).Value Or _
Cells(8, c).Value <= Cells(i, 11).Value Or _
Cells(9, c).Value <= Cells(i, 11).Value Or _
Cells(10, c).Value <= Cells(i, 11).Value Or _
Cells(11, c).Value <= Cells(i, 11).Value) Then

Select Case Cells(i, 4)
Case 1
Cells(i, c).Interior.ColorIndex = 11
With Cells(i, c)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 11
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 11
.Borders(xlLeft).Weight = xlThin
.Characters.Font.ColorIndex = 11
End With
Case 2
'Cells(i, 4) = 2
Cells(i, c).Interior.ColorIndex = 41
With Cells(i, c)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 41
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 41
.Borders(xlLeft).Weight = xlThin
.Characters.Font.ColorIndex = 41
End With
Case 3
Cells(i, c).Interior.ColorIndex = 37
With Cells(i, c)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 37
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 37
.Borders(xlLeft).Weight = xlThin
.Characters.Font.ColorIndex = 37
End With
Case 4
Cells(i, c).Interior.ColorIndex = 24
With Cells(i, c).Borders(xlEdgeTop)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 24
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 24
.Borders(xlLeft).Weight = xlThin
.Characters.Font.ColorIndex = 24
End With
End Select
End If
Next c
Next i

'Equipamento
ws.Range("O503:HN689").Select
With Selection
.Interior.ColorIndex = xlNone
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 37
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 37
.Borders(xlLeft).Weight = xlThin
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

For i = 503 To 689
For c = 15 To 222

If Cells(i, 4).Value = 0 Then
On Error Resume Next
ElseIf (Cells(5, c).Value >= Cells(i, 10).Value Or _
Cells(6, c).Value >= Cells(i, 10).Value Or _
Cells(7, c).Value >= Cells(i, 10).Value Or _
Cells(8, c).Value >= Cells(i, 10).Value Or _
Cells(9, c).Value >= Cells(i, 10).Value Or _
Cells(10, c).Value >= Cells(i, 10).Value Or _
Cells(11, c).Value >= Cells(i, 10).Value) And (Cells(5, c).Value <= Cells(i, 11).Value Or _
Cells(6, c).Value <= Cells(i, 11).Value Or _
Cells(7, c).Value <= Cells(i, 11).Value Or _
Cells(8, c).Value <= Cells(i, 11).Value Or _
Cells(9, c).Value <= Cells(i, 11).Value Or _
Cells(10, c).Value <= Cells(i, 11).Value Or _
Cells(11, c).Value <= Cells(i, 11).Value) Then

Select Case Cells(i, 4)
Case 1
Cells(i, c).Interior.ColorIndex = 11
With Cells(i, c)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 11
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 11
.Borders(xlLeft).Weight = xlThin
End With
Case 2
Cells(i, c).Interior.ColorIndex = 41
With Cells(i, c)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 41
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 41
.Borders(xlLeft).Weight = xlThin
End With
Case 3
'Cells(i, 4) = 3
Cells(i, c).Interior.ColorIndex = 37
With Cells(i, c)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 37
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 37
.Borders(xlLeft).Weight = xlThin
End With
Case 4
Cells(i, c).Interior.ColorIndex = 24
With Cells(i, c)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 24
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 24
.Borders(xlLeft).Weight = xlThin
End With
End Select
End If
Next c
Next i

'Mão de Obra
ws.Range("O692:HN717").Select
With Selection
.Interior.ColorIndex = xlNone
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 37
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 37
.Borders(xlLeft).Weight = xlThin
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

For i = 692 To 717
For c = 15 To 222

If Cells(i, 4).Value = 0 Then
On Error Resume Next
ElseIf (Cells(5, c).Value >= Cells(i, 10).Value Or _
Cells(6, c).Value >= Cells(i, 10).Value Or _
Cells(7, c).Value >= Cells(i, 10).Value Or _
Cells(8, c).Value >= Cells(i, 10).Value Or _
Cells(9, c).Value >= Cells(i, 10).Value Or _
Cells(10, c).Value >= Cells(i, 10).Value Or _
Cells(11, c).Value >= Cells(i, 10).Value) And (Cells(5, c).Value <= Cells(i, 11).Value Or _
Cells(6, c).Value <= Cells(i, 11).Value Or _
Cells(7, c).Value <= Cells(i, 11).Value Or _
Cells(8, c).Value <= Cells(i, 11).Value Or _
Cells(9, c).Value <= Cells(i, 11).Value Or _
Cells(10, c).Value <= Cells(i, 11).Value Or _
Cells(11, c).Value <= Cells(i, 11).Value) Then

Select Case Cells(i, 4)
Case 1
Cells(i, c).Interior.ColorIndex = 11
With Cells(i, c)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 11
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 11
.Borders(xlLeft).Weight = xlThin
End With
Case 2
Cells(i, c).Interior.ColorIndex = 41
With Cells(i, c)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 41
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 41
.Borders(xlLeft).Weight = xlThin
End With
Case 3
Cells(i, c).Interior.ColorIndex = 37
With Cells(i, c)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 37
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 37
.Borders(xlLeft).Weight = xlThin
End With
Case 4
Cells(i, c).Interior.ColorIndex = 24
With Cells(i, c)
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 2
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).ColorIndex = 2
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).ColorIndex = 24
.Borders(xlRight).Weight = xlThin
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).ColorIndex = 24
.Borders(xlLeft).Weight = xlThin
End With
End Select
End If
Next c
Next i


Set ws = Nothing

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox Timer - Start & " Seconds"

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Locked
  • Question
Help Cleaning Up Code
Replies
2
Views
365
RoryA
RoryA
K
  • Solved
formating question
Replies
3
Views
103
Micron
M
togenmoser
  • Solved
Help with VBA code error "For variable already in use"
2 3
Replies
22
Views
433
MARK858
MARK858
P
  • Question
Issue with button not running in spread sheet only in test mode
Replies
1
Views
214
6StringJazzer
6StringJazzer
P
  • Question
Excel to internal application
Replies
2
Views
199
pure vito
P

Forum statistics

Threads
1,215,759
Messages
6,126,730
Members
449,333
Latest member
Adiadidas

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top