Workbook_Open operates correctly in single step but not when run

[Deagles]

At workbook open my VB process checks 4 worksheets within the workbook for
row which should be deleted. The code works perfectly but is slow, so I
added first a StatusBar message showing progress, but as this did not work I
substituted a MsgBox statement at beginning and end. These MsgBox texts do
not operate either, whereas the original MsgBox delete messages continue to
work perfectly. To add to my puzzlement, the added code works perfectly when
I use single step.

Advice will be very gratefully received

Deagles

 

[Bob Phillips]

Post the code.

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Deagles]

Dear Bob Phillips

Thank you for your reply. Here is the code.
In normal run mode
MsgBox at StartUP and EndProcess does not display
I do not think the date test in StartUp works either.
In single step mode everything works as programmed.

I appreciate your help.

Deagles

Private Sub Workbook_Open()

StartUp:
MsgBox "Please wait until Open Process tells you it is finished"
ChangeCount = 0
' Code below inserted in case the large number of VLOOKUPs in the 4
worksheets
' was causing a timing issue with subsequent code.
NewOur = Hour(Now())
NewMin = Minute(Now())
NewSec = Second(Now()) + 20
Wait20 = TimeSerial(NewOur, NewMin, NewSec)
Application.Wait Wait20
' End of Delay code
ArchiveOpen = False
Folder = "Q:\Business Data Area\Purchasing Department\DE, Pricing
Reports\"
LastDate = DateValue(Sheets("CONTROL").Range("E1"))
If LastDate = Date Then GoTo EndProcess
Sheets("CONTROL").Range("E1") = DateValue(Date)

StartWorksheet:
For i = 1 To 4

RemoveCount = 0
ArchiveCount = 0
If i = 1 Then
WorkSheetName = "PRESS"
ElseIf i = 2 Then
WorkSheetName = "HIGH STREET"
ElseIf i = 3 Then
WorkSheetName = "DISTRIBUTOR"
Else
WorkSheetName = "INTERNET"
End If

Worksheets(WorkSheetName).Select
LastRow = Range("H65536").End(xlUp).Row

ReadWorksheet:
' Scan down data worksheet
For r = 3 To LastRow

Product = Range("A" & r)
If Product = "" Then
' Blank product = end of data
Exit For
End If

ErrorCheck:
If IsError(Cells(r, 8)) = True Then
' If Col(H) has an error the VLOOKUP has not worked and the row can be deleted
Rows(r & ":" & r).Select
Selection.Delete Shift:=xlUp
r = r - 1
RemoveCount = RemoveCount + 1
LastRow = LastRow - 1
GoTo NextRow
End If

AgeCheck:
Age = Range("V" & r)
If Age < 31 Then GoTo NextRow
' Data records over 30 days old are deleted and archived
ArchiveCount = ArchiveCount + 1
Source = WorkSheetName
PubIn = Range("B" & r)
PubOn = Range("C" & r)
Dealer = Range("D" & r)
Price = Range("E" & r)
Alert = Range("G" & r)
Supplier = Range("H" & r)
Buyer = Range("I" & r)
MaxFw = Range("J" & r)
Tag = Range("M" & r)
CSCost = Range("N" & r)
CSMargin = Range("P" & r)
CSMPC = Range("Q" & r)
TSCost = Range("S" & r)
TSMargin = Range("T" & r)
TSMPC = Range("U" & r)

ArchiveManage:
ArchiveOpen = False
For Each w In Workbooks
If w.Name = "MARGIN HISTORY CURRENT.xls" Then
ArchiveOpen = True
Exit For
End If
Next w
If ArchiveOpen = False Then
Workbooks.Open Filename:=Folder & "MARGIN HISTORY CURRENT.xls"
Else
Workbooks("MARGIN HISTORY CURRENT").Activate
End If
ArchiveNext = Range("A65536").End(xlUp).Row + 1

ArchiveData:
Range("A" & ArchiveNext) = Product
Range("B" & ArchiveNext) = Source
Range("C" & ArchiveNext) = PubIn
Range("D" & ArchiveNext) = PubOn
Range("E" & ArchiveNext) = Dealer
Range("F" & ArchiveNext) = Price
Range("G" & ArchiveNext) = Alert
Range("H" & ArchiveNext) = Supplier
Range("I" & ArchiveNext) = Buyer
Range("J" & ArchiveNext) = MaxFw
Range("K" & ArchiveNext) = Tag
Range("L" & ArchiveNext) = CSCost
Range("M" & ArchiveNext) = CSMargin
Range("N" & ArchiveNext) = CSMPC
Range("O" & ArchiveNext) = TSCost
Range("P" & ArchiveNext) = TSMargin
Range("Q" & ArchiveNext) = TSMPC

DeleteData:
Workbooks("PRICE COMPARISON").Activate
Rows(r & ":" & r).Select
Selection.Delete Shift:=xlUp
r = r - 1
LastRow = LastRow - 1

NextRow:
Next r

WorksheetStats:
' Now tell user any deletions at worksheet level
MsgText = ""
If RemoveCount > 0 Then
MsgText = RemoveCount & " record(s) with error removed from " &
WorkSheetName
End If
If ArchiveCount > 0 Then
MsgText = MsgText & Chr(10) & ArchiveCount & " record(s)
archived from " & WorkSheetName
End If
If MsgText <> "" Then
MsgBox MsgText
End If

NewRows:
' As rows have been deleted new rows with formulas from Row 2 must be created
LostRows = ArchiveCount + RemoveCount
ChangeCount = ChangeCount + LostRows
If LostRows > 0 Then
Range("A2:X2").Select
Application.CutCopyMode = False
Selection.Copy
Range(Cells(LastRow + 1, 1), Cells(LastRow + LostRows, 24)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

ColourColumns:
Columns("F:G").Select
With Selection.Interior
.ColorIndex = 36 'Colour = Pale Yellow
.Pattern = xlSolid
End With
Columns("L:Q").Select
With Selection.Interior
.ColorIndex = 36 'Colour = Pale Yellow
.Pattern = xlSolid
End With
Columns("H:K").Select
With Selection.Interior
.ColorIndex = 38 'Colour = Pale Pink
.Pattern = xlSolid
End With
Columns("R:U").Select
With Selection.Interior
.ColorIndex = 35 'Colour = Pale Green
.Pattern = xlSolid
End With
Columns("V").Select
With Selection.Interior
.ColorIndex = 34 'Colour = Pale Blue
.Pattern = xlSolid
End With

RedoBorders:
Columns("A:X").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

FormatPercents:
Columns("G:G").Select
Selection.NumberFormat = "0.00%"
Columns("Q:Q").Select
Selection.NumberFormat = "0.00%"
Columns("U:U").Select
Selection.NumberFormat = "0.00%"
Range("G3").Select
Selection.Copy
Range("G4:G999").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("Q3").Select
Selection.Copy
Range("Q4:Q999").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("U3").Select
Selection.Copy
Range("U4:U999").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If

NextWorksheet:
Next i

EndProcess:
' Close down process
If ArchiveOpen = True Then
Workbooks("MARGIN HISTORY CURRENT").Activate
ActiveWorkbook.Close SaveChanges:=False
End If
If ActiveWorkbook.Name <> "PRICE COMPARISON" Then
Workbooks("PRICE COMPARISON").Activate
End If
If ChangeCount > 0 Then
ActiveWorkbook.Save
End If

MsgText = "Open Checks on Price Comparison now completed"
CalendarWarning = DateValue(Sheets("CONTROL").Range("F2"))
' Workbook contains a manually maintained calendar (current till Jan 2011)
If CalendarWarning < Date Then
MsgText = MsgText & Chr(10) & "PRICE COMPARISON Calendar needs to be
updated." & Chr(10) _
& "If no update, Report process will soon fail. SEE MANUAL!"
End If
MsgBox MsgText
Worksheets("PRESS").Select

End Sub