Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Workbook_Open operates correctly in single step but not when run
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Workbook_Open operates correctly in single step but not when run
Post the code.
-- HTH Bob (there's no email, no snail mail, but somewhere should be gmail in my addy) "Deagles" wrote in message ... 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Workbook_Open operates correctly in single step but not when r
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 -- Deagles "Bob Phillips" wrote: Post the code. -- HTH Bob (there's no email, no snail mail, but somewhere should be gmail in my addy) "Deagles" wrote in message ... 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Excel 2002: Can I protect the whole file in a single step ? | Excel Discussion (Misc queries) | |||
Different outcome if I single Step or just run the code | Excel Programming | |||
How show value of variable in single step debug mode? | Excel Programming | |||
Works if I single step | Excel Programming | |||
Single Step Dialog Box | Excel Programming |