Make VBA Faster

[Sara.]

I'm looking to make my vba code run faster. Any suggestions?

Sub ShadeAllSw()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.DisplayPageBreaks = False
ActiveSheet.ChartObjects("Chart 3").Activate
Dim DrObj
Dim Pict
Set DrObj = ActiveChart.Shapes
'Deletes pictures off of the sheet

For Each Pict In DrObj
If Left(Pict.Name, 8) = "Freeform" Then
Pict.Select
Pict.Delete
End If
Next

ActiveSheet.ChartObjects("Chart 3").Activate
Dim depth
Dim numrows As Integer, rowcount As Integer
Dim ZoneCounter As Integer

Dim MyRange As Variant
MyRange = Sheets("Graphs").Range("A1:AC10000")

depth = MyRange(34, 15)
numzones = MyRange(41, 14)
numrows = MyRange(44, 14) * 2

ReDim topbot(numzones, 2) As Double
ReDim LogArray(numrows, 3) As Double

ZoneCounter = 1
Do While ZoneCounter <= numzones
topbot(ZoneCounter, 1) = MyRange(ZoneCounter + 1, 2)
topbot(ZoneCounter, 2) = MyRange(ZoneCounter + 1, 3)

ZoneCounter = ZoneCounter + 1
Loop


rowcount = 1
Do While rowcount <= numrows
LogArray(rowcount, 1) = MyRange(rowcount + 34, 17)
LogArray(rowcount, 2) = MyRange(rowcount + 34, 29)
LogArray(rowcount, 3) = MyRange(rowcount + 34, 28)


If LogArray(rowcount, 2) > 100 Then
LogArray(rowcount, 2) = 100
End If
rowcount = rowcount + 1
Loop

Dim depthcounter As Double

Dim FlagStart As Double
Dim FlagEnd As Double
Dim IsPay As Boolean

ZoneCounter = 1
Do While ZoneCounter <= numzones

FlagStart = 0
FlagEnd = 0
IsPay = False

Dim row As Double

depthcounter = topbot(ZoneCounter, 1)

Do While depthcounter <= topbot(ZoneCounter, 2)
row = 2 * (depthcounter - depth) + 1
If LogArray(2 * (depthcounter - depth) + 1, 3) = 0.5 Then
IsPay = True
If FlagStart = 0 Then
FlagStart = LogArray(2 * (depthcounter - depth) + 1, 1)
End If
End If
If IsPay = True And LogArray(2 * (depthcounter - depth) + 1, 3) = 0 Then
FlagEnd = LogArray(2 * (depthcounter - depth - 0.5) + 1, 1)
IsPay = False
End If
If FlagEnd = 0 And depthcounter = topbot(ZoneCounter, 2) Then
FlagEnd = topbot(ZoneCounter, 2)
End If
If FlagStart > 0 And FlagEnd > 0 Then
ShadeLeft FlagStart, FlagEnd
FlagStart = 0
FlagEnd = 0
End If
depthcounter = depthcounter + 0.5

Loop

ZoneCounter = ZoneCounter + 1
Loop

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
ActiveSheet.DisplayPageBreaks = True
End Sub
Sub ShadeLeft(PayStart As Double, PayEnd As Double)

ActiveSheet.ChartObjects("Chart 3").Activate
Dim MyRange As Variant
MyRange = Sheets("Graphs").Range("A1:AC10000")
Dim depth
depth = MyRange(34, 15)
Dim rowcount As Double
Set myCht = ActiveChart
Xleft = myCht.PlotArea.InsideLeft
xwidth = myCht.PlotArea.InsideWidth
Ytop = myCht.PlotArea.InsideTop
Yheight = myCht.PlotArea.InsideHeight
'Yheight = 4172.5
Xmin = myCht.Axes(1).MinimumScale
Xmax = myCht.Axes(1).MaximumScale
Ymax = myCht.Axes(2).MinimumScale
Ymin = myCht.Axes(2).MaximumScale
Dim numrows As Double
numrows = MyRange(44, 14) * 2

ReDim LogArray(numrows, 2) As Double


rowcount = 1
Do While rowcount <= numrows
LogArray(rowcount, 1) = MyRange(rowcount + 34, 17)
LogArray(rowcount, 2) = MyRange(rowcount + 34, 29)


If LogArray(rowcount, 2) > 100 Then
LogArray(rowcount, 2) = 100
End If
rowcount = rowcount + 1
Loop

' first point
Xnode = Xleft
Ynode = Ytop + (Ymax - PayStart) * Yheight / (Ymax - Ymin)
Set myBuilder = myCht.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)

' remaining points
For i = PayStart To PayEnd
Xnode = Xleft + (LogArray((2 * (i - depth)), 2) - Xmin) * xwidth / (Xmax - Xmin)
Ynode = Ytop + (Ymax - LogArray((2 * (i - depth)), 1)) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode
Next i

Xnode = Xleft
Ynode = Ytop + (Ymax - PayEnd) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode

Xnode = Xleft
Ynode = Ytop + (Ymax - PayStart) * Yheight / (Ymax - Ymin)
myBuilder.AddNodes msoSegmentLine, msoEditingAuto, Xnode, Ynode

Set myShape = myBuilder.ConvertToShape

With myShape
.Fill.ForeColor.SchemeColor = 5
.PictureFormat.TransparentBackground = msoCTrue
.Fill.Transparency = 0.5
If PayStart = PayEnd Then
.Line.Visible = True
Else
.Line.Visible = False
End If
End With
End Sub