Encountering pause while running VBA macro

[djgrendellv]

I wrote a VBA macro that, when run, copies information from one spreadsheet, creates a new spreadsheet and copies the information to that spreadsheet, then removes all empty rows and columns. It works just fine, but when the macro is run for the first time, there appears to be a 10 second pause (the hourglass appears) before the macro actually does its job. Subsequent runs of the macro don't produce the pause. Restarting the workbook introduces the pause again, but again only during the first run.

Am I right in assuming that VBA is compiling the macro, which is causing the pause? And can anything be done about it? Any help would be appreciated. Here's the code:

\code

' Delete WebTimeForm If Worksheet Exists
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim wsSheet As Worksheet
On Error Resume Next
Set wsSheet = Sheets("WebTime Form")
On Error GoTo 0
If Not wsSheet Is Nothing Then
Sheets("WebTime Form").Delete
End If

' Create WebTimeForm and Create Row Headers & Formatting
Sheets.Add.Name = "WebTime Form"
ActiveSheet.Move After:=Worksheets(Worksheets.Count)
Sheets("Sun").Select
Range("A7:A29").Copy
Sheets("WebTime Form").Select
Range("A3:A25").PasteSpecial xlValues
ActiveWindow.DisplayGridlines = False
Range("A1:Z2").HorizontalAlignment = xlCenter
Range("A1:Z2").Font.Bold = True
Range("B3:X25").NumberFormat = "0.00"


' Copy Worksheet Info
Sheets("Sun").Select
If (Application.WorksheetFunction.Sum(Range("AB30:AX30")) <> "0") Then
Range("AB6:AZ29").Copy
Sheets("WebTime Form").Select
Range("B1:Z1") = "Sun"
Range("B2:Z25").PasteSpecial xlValues
End If

' Format WebTimeForm Worksheet
Sheets("WebTime Form").Select
Columns("A:A").ColumnWidth = 5.43
Columns("B:X").ColumnWidth = 4.57
Columns("Y:Z").ColumnWidth = 7.14
Range("A1:Z25").Select
With Selection.Font
.Name = "Arial"
.Size = 8
End With
Range("B3:Z25").Select
Selection.HorizontalAlignment = xlCenter


' Turn Zeros to Blanks
For Row = 3 To 25
For Column = 2 To 26
If Cells(Row, Column) = 0 Then
Cells(Row, Column) = ""
End If
Next Column
Next Row


' Remove Blank Columns
With ActiveSheet
For Column = 26 To 2 Step -1
Count = 0
For Row = 3 To 25
If Cells(Row, Column) = "" Then
Count = Count + 1
End If
Next Row
If Count = 23 Then
Columns(Column).EntireColumn.Delete
End If
Next Column
End With

' Remove Blank Rows
With ActiveSheet
For Row = 25 To 3 Step -1
Count = 0
For Column = 2 To 26
If Cells(Row, Column) = "" Then
Count = Count + 1
End If
Next Column
If Count = 25 Then
Rows(Row).EntireRow.Delete
End If
Next Row
End With
Range("A1").Select

' Merge Day Headers
Dim Day1 As String
Day1 = "Sun"
Dim SearchRange As Range
Dim FoundCells As Range
Dim FoundCell As Range
Dim FindWhat As String
Dim MatchCase As Boolean
Dim LookIn As XlFindLookIn
Dim LookAt As XlLookAt
Dim SearchOrder As XlSearchOrder
Set FoundCells = FindAll(SearchRange:=Range("B1:X1"), FindWhat:=Day1, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
If FoundCells Is Nothing Then
' Do nothing
Else
Range(FoundCells.Address).Merge
End If


' Create borders and alternate row shading
Dim LastColumn As Integer
Dim LastRow As Long
Dim LastCell As Range
If WorksheetFunction.CountA(Cells) > 0 Then

'Search for any entry, by searching backwards by Rows.
LastRow = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

'Search for any entry, by searching backwards by Columns.
LastColumn = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Range("A1", Cells(LastRow, LastColumn).Address).Select
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic


Dim table_start_range As Range
Dim header_column As Long
Dim last_column As Long
Dim row_start As Long
Dim row_count As Long
Dim header_row As Long
Dim last_row As Long
Dim column_start As Long
Dim column_count As Long
Dim rowidx As Long
Dim colorflag As Boolean
Dim colorpick As Long
Dim COLOR_Blue As Long
Dim COLOR_LightYellow As Long
Dim COLOR_LightGreen As Long
COLOR_Blue = RGB(0, 0, 255)
COLOR_LightYellow = RGB(255, 255, 153)
COLOR_LightGreen = RGB(204, 255, 204)

'Format the header column
Set table_start_range = Range("A1")
header_column = table_start_range.Columns(1).Column
last_column = ActiveSheet.UsedRange.Columns.Count
row_start = table_start_range.Rows(1).Row
row_count = table_start_range.CurrentRegion.Rows.Count
Range(Cells(row_start, header_column), Cells(row_start + row_count - 1, _
header_column)).Font.Bold = True
Range(Cells(row_start, header_column), Cells(row_start + row_count - 1, _
header_column)).Font.Color = COLOR_Blue

'Format the header row
Set table_start_range = Range("A1")
header_row = table_start_range.Rows(2).Row
last_row = ActiveSheet.UsedRange.Rows.Count
column_start = table_start_range.Columns(1).Column
column_count = table_start_range.CurrentRegion.Columns.Count
Range(Cells(header_row, column_start), Cells(header_row, _
column_start + column_count - 1)).Font.Bold = True
Range(Cells(header_row, column_start), Cells(header_row, _
column_start + column_count - 1)).Font.Color = COLOR_Blue

'Format the data columns with alternating colors
For rowidx = row_start + 2 To row_start + row_count - 1
colorflag = Not colorflag
If colorflag Then
colorpick = COLOR_LightYellow
Else
colorpick = COLOR_LightGreen
End If
Range(Cells(rowidx, header_column + 1), Cells(rowidx, last_column)).Interior.Color = colorpick
Next rowidx

Set table_start_range = Nothing
End With
End If
Range("A1").Select
ActiveSheet.Protect UserInterfaceOnly:=True
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

----

Function FindAll(SearchRange As Range, FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False) As Range
Dim FoundCell As Range
Dim FoundCells As Range
Dim LastCell As Range
Dim FirstAddr As String
With SearchRange
Set LastCell = .Cells(.Cells.Count)
End With

Set FoundCell = SearchRange.Find(What:=FindWhat, After:=LastCell, _
LookIn:=LookIn, LookAt:=LookAt, SearchOrder:=SearchOrder, MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FoundCells = FoundCell
FirstAddr = FoundCell.Address
Do
Set FoundCells = Application.Union(FoundCells, FoundCell)
Set FoundCell = SearchRange.FindNext(After:=FoundCell)
Loop Until (FoundCell Is Nothing) Or (FoundCell.Address = FirstAddr)
End If
If FoundCells Is Nothing Then
Set FindAll = Nothing
Else
Set FindAll = FoundCells
End If
End Function

/end code

 

[xenou]

Hi,
I've never really encountered any code that takes 10 seconds to compile - even when there 10 times what you have here. And its not immediately obvious why anything would take that long. It may help to break it up into more than one macro. That could help in 2 ways - you can isolate the piece that may be the troublemaker. It will help you maintain the code and possibly even re-use parts of it.

You may like to put screenupdating back on and you may see what's the slowest piece.

For what its worth, I have a macro that usually takes about 2-3 seconds and sometimes takes 15-30 seconds so there's non-vba factors that come into play (network traffic perhaps).

Sub Macro1()
Call Macro2
Call Macro3
Call Macro4
Call Macro5
Call Macro6
End Sub
'---------------------------
Sub Macro2()
'//code to create new sheet
End Sub
'---------------------------
Sub Macro3()
'//code to format new sheet
End Sub
'---------------------------
Sub Macro4()
'//code to deal with zeros and blanks
End Sub
'---------------------------
Sub Macro5()
'//code to merge headers
End Sub
'---------------------------
Sub Macro6()
'//code to do more formatting
End Sub