I am experiencing baffling behavior with an Excel macro running in Office 365 that I have reduced to the following block. The Excel process becomes corrupted if:
Sheet1!A1:A1000 are filled with letters (just "A" is sufficient). This is to create a sufficiently large computation load in the macro. Too little load and it doesn't break things.
A formula references something that will be altered by the macro. E.g., set Sheet1!B1 formula to =ISNUMBER(E1).
The TestMacro() below is invoked from within the VBA editor (using F5).
(Omit any of these test conditions and the behavior described below does not occur. However with more complex sheets it occurs much more easily, including not requiring the macro be invoked from within the VBA editor.)
Sub TestMacro()
On Error GoTo EH
Dim row As Integer
Dim col As Integer
row = 1
col = 5
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Do While Not IsEmpty(Cells(row, 1).Value)
Cells(1, col).Value = Cells(row, 1).Value & " col"
Cells(3, col).FormulaR1C1 = "test" & Cells(1, col).Value
Range("E2:K2").Select
Selection.Copy
Cells(2, col).Select
ActiveSheet.Paste
Application.CutCopyMode = False
col = col + 8
row = row + 1
Loop
CleanUp:
On Error Resume Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Exit Sub
EH:
' Do error handling
GoTo CleanUp
End Sub
The symptom I check to see whether the macro has messed up Excel is to go to File >> Save As and when things are not right I get a blank dialog screen like this:
Further testing shows that if I omit the two lines in TestMacro that suspend and then resume Application.Calculation then no problems arise.
I have tried putting a simple DoEvents call immediately before Exit Sub but that puts the Excel instance into a state in which the cursor perpetually flits rapidly between normal and Wait.
I suspect there is something structurally incorrect in this VBA subroutine structure, but it is tricky to reveal, and I can't begin to understand what is going wrong.
Related
I export two strings of text from an Excel spreadsheet to Word, use the Word Compare function to highlight and underline the differences between the two, and then export that final string with the formatting back to the Excel spreadsheet.
When this code runs down the column, sometimes the ActiveSheet.Paste line, gives me
Run-time error '1004':
Microsoft Excel cannot paste the data.
Dim previous As String: previous = Cells(i, 19).Value
Dim current As String: current = Cells(i, 20).Value
Dim wordApp As Word.Application: Set wordApp = New Word.Application
wordApp.Visible = True
Dim firstdoc As Word.Document: Set firstdoc = wordApp.Documents.Add
firstdoc.Paragraphs(1).Range.Text = previous
Dim seconddoc As Word.Document: Set seconddoc = wordApp.Documents.Add
seconddoc.Paragraphs(1).Range.Text = current
Dim lastdoc As Word.Document
Set lastdoc = wordApp.CompareDocuments(firstdoc, seconddoc, wdCompareDestinationNew)
With lastdoc.ActiveWindow.View.RevisionsFilter
.Markup = wdRevisionsMarkupAll
.View = wdRevisionsViewFinal
End With
lastdoc.Content.FormattedText.Copy
Cells(i, 20).Activate
Cells(i, 20).Select
PAUSE 3
ActiveSheet.Paste 'Where the program always stops for some reason.
firstdoc.Close SaveChanges:=wdDoNotSaveChanges
seconddoc.Close SaveChanges:=wdDoNotSaveChanges
lastdoc.Close SaveChanges:=wdDoNotSaveChanges
wordApp.Visible = False
When I hit debug and F5 (Continue), it begins to work again like normal. If I have 30 rows of text, this might occur 5-6 times throughout the program execution. I know it has nothing to do with the extent of text it's handling because this error occurs randomly down the row, sometimes when pasting a large block of text or sometimes pasting a small block of text.
Someone suggested that I use the PAUSE 3 Subroutine to slow down the program for Excel to catch up. It did decrease the frequency of the error message.
What could be going on and how do I fix it?
Sub PAUSE(Period As Single)
Dim t As Single
Period = 0.5
t = Timer + Period
Do
DoEvents
Loop Until t < Timer
End Sub
You can retry the paste if it fails - this has always worked for me when a single attempt to paste was failing sometimes.
Replace this:
lastdoc.Content.FormattedText.Copy
Cells(i, 20).Activate
Cells(i, 20).Select
PAUSE 3
ActiveSheet.Paste 'Where the program always stops for some reason
with:
Dim n As Long, pasted As Boolean
'...
'...
lastdoc.Content.FormattedText.Copy
pasted = False 'reset paste status flag
For n = 1 To 10 'try 10 times to paste
On Error Resume Next 'ignore any paste error
ActiveSheet.Paste Destination:=ActiveSheet.Cells(i, 20)
pasted = (Err.Number = 0) 'no error = pasted OK
On Error GoTo 0 'stop ignoring errors
If pasted Then Exit For 'exit if pasted OK
DoEvents
Next n
If Not pasted Then 'was there a problem pasting?
MsgBox "Problem pasting!"
End If
'...
'...
I'm currently trying to put together some VBA in excel. Not overly familiar, but have managed to collate the following;
Sub PasteBOMLines()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Set up loop
Dim loopCount As Integer 'Number of cycles to complete
Dim loopCountNow As Integer 'Number of cycles completed so far
loopCount = Range("B4") 'Get number of cycles to complete from cell
loopCountNow = 0 'Set current number of loops to 0
Range("B6:N24").Select
Selection.Copy
Do While loopCount > loopCountNow 'Start of loop, continue looping until the number of loops completed is equal to number of loops to complete
'Paste and Group the relevant cell
ActiveCell.Offset(19, 0).Range("A1:M19").Select
ActiveSheet.Paste
ActiveCell.Offset(3, 0).Range("A1:F16").Select
Selection.Rows.Group
'Resolves loop
loopCountNow = loopCountNow + 1 'integer loops completed by 1
Loop 'returns code to the "do while" bit
'Change settings to default
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub
I'm having issues getting the grouping bit to work. If I leave out this bit;
ActiveCell.Offset(3, 0).Range("A1:F16").Select
Selection.Rows.Group
The copy/paste function works fine, but once added in, the first copy/paste will group, then I get this error;
"Paste method of Worksheet class failed"
Any ideas? Thank you
This is my second post about this macro. Although the first post received a few responses, none of the responses solved the problem (thank you for responding though).
Scenario:
I have about 20 sub-spreadsheets with links to external sources. The number of links per spreadsheet varies from about 500 to 10,000. A master spreadsheet calls macros to open each sub-spreadsheet in turn and update the links.
Each sub-spreadsheet has a dashboard that tells me how many links remain to be updated. This is done by counting the number of “N/A” values in each tab, then summing these counts in cell A20. As the links are updated, the value in A20 counts down to zero.
Sub Sub01()
Dim NAtotal As Integer
Set ActiveWKB = Workbooks.Open("Sub01.xlsm")
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.CalculateFull
ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
NAtotal = Worksheets("Dashboard").Cells(20, "C").Value
MsgBox (NAtotal) 'Tells me how many cells remain to be updated – starts off at 4450.
NAtotal = 100 'Debugging effort to let me know that NAtotal does adjust.
MsgBox (NAtotal)
Do Until NAtotal = 0
Application.ScreenUpdating = True
MsgBox (NAtotal) 'Another debugging effort to monitor NAtotal. Starts at 100, then jumps to (and remains at) 4450 on the second loop and all subsequent loops.
NAtotal = Worksheets("Dashboard").Cells(20, "C").Value 'Resets NAtotal to the value in C20. This never changes, but remains at 4450.
DoEvents
Loop
Application.Calculation = xlManual
MsgBox ("Done")
Sheets("Dashboard").Activate
Range("B1").Select
ActiveWorkbook.Save
ActiveWindow.Close
End Sub`
The macro should continue to loop until cell A20 hits zero, and then stop.
Cell A20 does count down, but variable NAtotal remains at its initial value.
Any guidance/recommendations are appreciated.
Hi the code below worked for me. Try use the same method instead of using a loop. The schedule will trigger every second until the NATotal = 0 logically anyway. Just update the code to fit your references.
Public firstOpen As Boolean
Sub testForm()
Dim cellCount As Integer
Dim s1 As Sheet1
Set s1 = Sheet1
Dim cellCol As Integer
Dim activeWbk As Workbook
Dim ws As Worksheet
If firstOpen = False Then
firstOpen = True
Set activeWbk = Workbooks.Open("C:\Example\Link2.xlsm")
Set ws = activeWbk.Sheets("Sheet1")
Application.Calculation = xlCalculationAutomatic
Application.CalculateFull
activeWbk.UpdateLink Name:=ActiveWorkbook.LinkSources
CreateNewSchedule
Exit Sub
Else
Set activeWbk = Workbooks("Link2.xlsm")
Set ws = activeWbk.Worksheets("Sheet1")
End If
cellCount = ws.Range("N2").Value
If cellCount = 0 Then
MsgBox ("Done...")
Application.Calculation = xlCalculationManual
firstOpen = false
Else
Debug.Print cellCount
CreateNewSchedule
End If
'Application.Calculation = xlCalculationManual
End Sub
Sub CreateNewSchedule()
Application.OnTime Now + TimeValue("00:00:01"), Procedure:="testForm", Schedule:=True
End Sub
The problem
I have a workbook (A) which includes some macros as well as being linked to another Excel-file (data source). The workbook works perfectly and without problems if I only have this individual workbook open. If I open another random xlsx-file everything looks OK at first. But as soon as I make any updates whatsoever (e.g. pressing F2 in an empty cell and then enter) in workbook A, both workbooks seems to freeze. I can still close the workbooks in a normal procedure and the macro-button in workbook A works fine (and will trigger the macro), but I'm unable to change tabs in wb A and the tabs in the second workbook disappears. I can see the cursor, but the green Excel-border/box around target-cells are gone in both workbooks. I am also unable to update any of the cells in the workbooks...
What I've tried
I have tried to;
remove all data source connections
remove all macros (one by one, but problem still exist without any macros in wb A...)
go through the macros to see if they causes any errors (which they don't as far as I can see)
two other xlsm-files (unrelated to wb A) does not cause this type of error
i've tried to use application.ScreenUpdating = False, .EnableEvents = False, .Calculation = xlCalculationManual, and setting them back to original values at the end.
Code
-Range("B4") is a dropdown-list without blanks. The following macro lies in Sheet1:
Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ApplicationON:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
If Intersect(Target, Range("B4")) Is Nothing Then Exit Sub
Call conditionalFormatting.conditionalFormatting
ApplicationON:
On Error Resume Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
-The following macro lies in a module called "conditionalFormatting":
Sub conditionalFormatting()
On Error GoTo ApplicationON:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim DASHBOARD As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim cel As Range
Dim col1 As Integer
Dim col2 As Integer
Set DASHBOARD = Sheets("DASHBOARD")
Set rng1 = Range("R15:R45")
Set rng2 = Range("R15:Z45")
col1 = 18
col2 = 26
With rng2
.Cells.Font.Bold = False
.Cells.Font.Italic = False
.Cells.Font.Size = 11
End With
For Each cel In rng1
Select Case cel.Value
Case _
"Case1", _
"Case2"
Range(Cells(cel.Row, col1), Cells(cel.Row, col2)).Font.Bold = True
Case _
"Case3", _
"Case4"
Range(Cells(cel.Row, col1), Cells(cel.Row, col2)).Font.Size = 8
Case _
"Case5", _
"Case6"
Range(Cells(cel.Row, col1), Cells(cel.Row, col2)).Font.Italic = True
End Select
Next
ApplicationON:
On Error Resume Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
-The following macro lies in a module called "ExportToPDF" and has a button in worksheet "DASHBOARD" (sheet1):
Sub ExportToPDF()
On Error GoTo ApplicationON:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim pt As Range
dateStamp = Format(Now(), "yyyymmdd\_hhmm")
workbookPath = ActiveWorkbook.Path & "\"
workbookName = ActiveWorkbook.Name
file_Name = dateStamp & "_" & Sheets("DASHBOARD").Range("A1") & ".pdf"
filePath = workbookPath & file_Name
With Worksheets("DASHBOARD").PageSetup
.PrintArea = "A6:O42"
.Orientation = xlLandscape
End With
Set pt =
Worksheets("DASHBOARD").Range(Worksheets("DASHBOARD").PageSetup.PrintArea)
pt.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=filePath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
MsgBox "PDF file has been created: " _
& filePath
ApplicationON:
On Error Resume Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
After some additional testing
It seems it has to do with looping and module Workbook_change + my dropdown-list which does not include any blank values. But still strange that it works perfectly without any other wb open, but only becomes a problem when opening an additional wb. Can't see that the code is running either when both wbs freezes...
1) made a copy and removed the data connections (so it doesn't interfere), and saving and closing the workbook
2) Opening the workbook (without any of the errorHandling and application-statement) without make any changes/updates in the spreadsheets, and opening a second file (slsx) - error occur
3) Opening the workbook (without any of the errorHandling and application-statement) and writing "=1+1" in an random empty cell, and opening a second file (slsx) - error occur
4) Opening the workbook (without any of the errorHandling and application-statement) and changing the dropdown-list once (calling the worksheet_change macro), and opening a second file (slsx) - error occur
5) Opening the workbook (in original state as posted) without making any changes/updates in the spreadsheets, and opening a second file (slsx) - error occur
6) Opening the workbook (in original state as posted) and writing "=1+1" in an random empty cell, and opening a second file (slsx) - error does not occur
7) Opening the workbook (in original state as posted) and changing the dropdown-list once (calling the worksheet_change macro), and opening a second file (slsx) - error occur
8) If I insert a blank value in the drop-downlist (workbook in original state as posted) and selecting the blank value, and opening a second file (slsx) - error does not occur
9) Selecting a value in dropdown-list - error occur
8) Removing the ExportToPDF- and conditionalFormatting-modules, and including proposed adjustment to Worksheet_change module (i.e. removing code from sheet1 and inserting it into module).
8.1 just opening second file without making changes to xlsm, and having value in dropdown-list - error occur
8.2 typing 1+1 in random empty cell - error occur
8.3 changing dropdown-list once (to another value) - error occur
8.4 changing dropdown-list to blank - error does not occur
If you cause an error in any of these functions, you set Application.EnableEvents = True. So... If those are triggered from a call originating from inside an event handler, you lose your re-entry protection. You also unconditionally do this at the top of everything:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
That smacks of cargo-cult behavior. You should only be performing this work where it is necessary, and close to the place where it is necessary. Whatever performance gains you think you're getting by doing this are probably just illusory. In fact, repeatedly messing with the Application state is probably doing more harm than good from a performance standpoint.
The solution is to not rely on Excel to guard re-entry into your event handler - do it manually:
Private reentryFlag As Boolean 'Module level
Sub Worksheet_Change(ByVal Target As Range)
If reentryFlag Then Exit Sub
reentryFlag = True
On Error GoTo Handler
If Intersect(Target, Range("B4")) Is Nothing Then Exit Sub
conditionalFormatting.conditionalFormatting
Handler:
reentryFlag = False
End Sub
Seems like there was a mysterious error with the Excel-file. I rebuilt the dashboard and it worked as expected. To be on the safe-side I skipped the "Workbook_change"-code linked to a filter and just used a simple button to execute the code instead. Thanks for everyone's input.
I am relatively new to VBA. And when I was working on a worksheet I created a code that automatically hides/unhides rows based on a condition in a column row (0 unhide/1 hide). This relatively easy macro worked well until I added a different sheet. As there are no macros in this sheet I dont think it is related. But now everytime it gives a runtime error on the END IF function and I don't know how to solve it. There is probably a simple solution, but I cannot find it.
Here is the code:
Private Sub Worksheet_Calculate()
Application.ScreenUpdating = False
Dim LastRow As Long, c As Range
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "BA").End(xlUp).Row
On Error Resume Next
For Each c In Range("BA34:BA56,BA73:BA74,BA76:BA107")
If c.Value = 1 Then
c.EntireRow.Hidden = True
ElseIf c.Value = 0 Then
c.EntireRow.Hidden = False
End If
Next
On Error GoTo 0
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Remove or comment out the On Error Resume Next if you want more complete debugging information. It should not be necessary in an event macro that runs as often as Worksheet_Calculate.
Apply a parent worksheet reference to the range object. The worksheet may have volatile formulas that are triggering a calculation event due to changes on the other worksheet.
I've added a wide condition so that the code will only run if the parent worksheet holds the ActiveSheet property. The worksheet may have volatile¹ formulas that are triggering a calculation event due to changes on the other worksheet (or even another workbook).
LastRow does nothing after its assignment (which is problematic) so I removed it.
I simplified the Range.Hidden property to a single line.
Private Sub Worksheet_Calculate()
If Me.Name = Activesheet.Name Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim c As Range
For Each c In Me.Range("BA34:BA56,BA73:BA74,BA76:BA107")
c.EntireRow.Hidden = CBool(c.Value2)
Next c
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
¹ Volatile functions recalculate whenever anything in the entire workbook changes, not just when something that affects their outcome changes. Examples of volatile functions are INDIRECT, OFFSET, TODAY, NOW, RAND and RANDBETWEEN. Some sub-functions of the CELL and INFO worksheet functions will make them volatile as well.
Just to finish the thread. I solved it based on a combination of the code you wrote and mine, as the 0 should be the trigger to unhide as well. I guess the error line caused the issue.
Private Sub Worksheet_Calculate()
Application.ScreenUpdating = False
Dim LastRow As Long, c As Range
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "BA").End(xlUp).Row
On Error Resume Next
For Each c In Range("BA34:BA56,BA73:BA74,BA76:BA107")
If c.Value = 1 Then
c.EntireRow.Hidden = True
ElseIf c.Value = 0 Then
c.EntireRow.Hidden = False
End If
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub