VBA/Excel suddenly running slow with no code changes - vba

I came to work this morning and began work on the same file I left from yesterday. Now Excel slows way down whenever a macro is assigning values to cells or clearing them. It was lightning quick before I left yesterday, now it takes 2-3 seconds at a time to assign a value to a cell.
Right now, other files with similar macros run fine. This happened to another file a while back, so I reverted to a previous version of the file and it worked fine, while the slow file continued to work slow. I guess I can do that now, but in this case that would take a whole lot of work to bring that file to where I have this version. I was wondering if anyone knows what might be going on. Is this one of the things Excel files just do from time to time (like a kind of file corruption), or is there a fix?
I have provided the macro below, although it happens throughout the file whenever values are assigned to cells. I've marked the trouble areas by denoting <---SLOW HERE.
I know this all sounds very vague, and I know I am giving very little to go on. Perhaps insufficient info, but this is all I have. There is no reason (that I can see) that this should be happening. I've even restarted the computer...just in case the problem was external to Excel. No change.
If you need more info I will do my best to expound if I can. Thanks for your help and understanding.
Example Macro:
Sub DeleteButton1_Click()
Call UnlockSettingsWorksheet
Sheet24.Range("C18:E18").Value = "" <---SLOW HERE
Dim i As Long
For i = 18 To 21
Sheet24.Range("C" & i & ":E" & i).Value = Sheet24.Range("C" & i + 1 & ":E" & i + 1).Value <---SLOW HERE
Next
Sheet24.Range("C22:E22").Value = "" <---SLOW HERE
Call LockSettingsWorksheet
End Sub

As mentioned in the comments, there might be a lot of factors contributing to this change:
any actions triggered in these events:
Worksheet_Calculate()
Worksheet_Change()
Worksheet_FollowHyperlink()
Worksheet_SelectionChange()
Workbook_SheetCalculate()
Workbook_SheetChange()
Workbook_SheetFollowHyperlink()
external links, and the external file(s) moved or deleted
database connections (check Data Tab -> Connections) (doubtful)
Invalid Named Ranges (Formula Tab -> Name Manager; any Refs?)
Data validation rules (Data Tab -> Data Validation -> clear all)
Are you opening the file from a network location - this will make it much slower
Conditional Formatting rules? - remove all
Any hidden objects? (Alt + F10 - delete all)
Hidden formatting (what is the last used cell with data?); this may not be relevant for your case
Corrupt file
If the file is corrupt, and it's feasible, try re-creating it from scratch, and run this function first
If it's not corrupt, one of the first things I'd try is to disable all Excel functionality before the macro:
Sub DeleteButton1_Click()
'UnlockSettingsWorksheet
FastWB '<--- Disables all Application and Worksheet level settings
With ThisWorkbook.Worksheets("Sheet24") 'Fully qualified worksheet
.Range("C18:E18").Value2 = vbNullString
Dim i As Long
For i = 18 To 21
.Range("C" & i & ":E" & i).Value2 = .Range("C" & (i + 1) & ":E" & (i + 1) ).Value2
Next
.Range("C22:E22").Value2 = vbNullString
End With
XlResetSettings '<--- Restores all Excel settings to defaults
'LockSettingsWorksheet
End Sub
.
Public Sub FastWB(Optional ByVal opt As Boolean = True)
With Application
.Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
.DisplayAlerts = Not opt
.DisplayStatusBar = Not opt
.EnableAnimations = Not opt
.EnableEvents = Not opt
.ScreenUpdating = Not opt
End With
FastWS , opt
End Sub
Public Sub FastWS(Optional ByVal ws As Worksheet, Optional ByVal opt As Boolean = True)
If ws Is Nothing Then
For Each ws In Application.ThisWorkbook.Sheets
OptimiseWS ws, opt
Next
Else
OptimiseWS ws, opt
End If
End Sub
Public Sub OptimiseWS(ByVal ws As Worksheet, ByVal opt As Boolean)
With ws
.DisplayPageBreaks = False
.EnableCalculation = Not opt
.EnableFormatConditionsCalculation = Not opt
.EnablePivotTable = Not opt
End With
End Sub
Public Sub XlResetSettings() 'default Excel settings
With Application
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.DisplayStatusBar = True
.EnableAnimations = False
.EnableEvents = True
.ScreenUpdating = True
Dim ws As Worksheet
For Each ws In Application.ThisWorkbook.Sheets
With ws
.DisplayPageBreaks = False
.EnableCalculation = True
.EnableFormatConditionsCalculation = True
.EnablePivotTable = True
End With
Next
End With
End Sub
Maybe this will eliminate some VBA causes

I started noticing Range.Value = ... operations being significantly slow once upgraded to a 64 bit edition. Aside form the normal stuff like .ScreenUpdating and .Calculation, two things I've discovered significantly improve the speed are:
Change the cursor to xlWait prior to your operation, and back to xlDefault once done.
Public Sub MyMacro()
On Error Goto Exception
Application.Cursor = xlWait
' Do something here.
Exception:
Application.Cursor = xlDefault
End Sub
Use .Value2 instead of .Value
Sheet1.Range("A1").Value2 = "The quick brown fox jumps over the lazy dog."

Related

How to copy between sheets In vba, I tried to record macro but it doesn't work

Hello I have this program that will get data from yahoo finance in one sheet then choose the numerical data and then paste it in the my first sheet under the ticker.
Sub fundamentals()
For i = 2 To Sheets(1).Cells(1, 1).End(xlToRight).Column
ticker = Sheets(1).Cells(1, i)
qurl = "https://finance.yahoo.com/quote/" & ticker & "/key-statistics?p=" & ticker & ""
Sheets(2).Select
Sheets(2).Cells.Clear
With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=Sheets(2).Range("A1"))
.BackgroundQuery = True
.Refresh BackgroundQuery = False
End With
Sheets(2).Range("B1:B67").Copy
Sheets(1).Select
Cells(2, i).Select
ActiveSheet.Paste
CutCopyMode = False
Next i
End Sub
It works fine but until it should paste it self to my first sheet, it does not work but in the left corner it says press enter to select destination or paste. I want to make it work automatically so it paste by itself.
Kind regards
There are multiple things which are not inheritly wrong, but a bad coding practice in your code.
You should avoid using Select, ActiveSheet, Active... like a plague as it comes with a "nice bundle of unforeseen issues which will end up hurting your program in a long run". I would definitely recommend reading this question here, before even doing any further coding yourself:
Also, utitilize the procedures. Don't just dump everything into huge chunks of code. Your future self will thank you later for readability (or anyone who tries to update the code after you, even more).
I'm not exactly sure, if what I'm about to do is right, as it's not exactly clear from your original question, what the expected result would be, but this should serve as at least as some form of template of what your code should look like:
Private Sub update_table()
Sheets(2).Cells.Clear
Dim qurl As String
Dim ticker As Long
For i = 2 To Sheets(1).Cells(1, 1).End(xlToRight).Column
ticker = Sheets(1).Cells(1, i)
qurl = "https://finance.yahoo.com/quote/" & ticker & "/key-statistics?p=" & ticker & ""
With Sheets(2).QueryTables.Add(Connection:="URL;" & qurl, Destination:=Sheets(2).Range("A1"))
.BackgroundQuery = True
.Refresh BackgroundQuery = False
End With
Next i
End Sub
and the copy_paste which invokes update_table()
Private Sub cp_table()
Call update_table
Sheets(2).Range("B1").CurrentRegion.Copy
Sheets(1).Range("A2").PasteSpecial
End Sub
If you can update your question with expected input data and expected output, I can edit my answer accordingly to make sure the code works and doesn't only serve as a pseudo-code.

Transferring comments from one worksheet to another without using clipboard

I have a VBA script which add's comments to a background worksheet, which is working great. The problem I am having is moving this to a front worksheet.
I can use copy and paste special xlPasteComments but this then really slows down the update process. I have included below a section of what will be repeating code. If I use values it does not include the comments (I left this in to show) and I have tried Dim separating them out but this just causes as error with object not being supported.
If ws.Range("B9") = ("January") Then
Dim a As Long
Dim b As Long
ws.Range("J8:AN51").Value = area.Range("E2:AI45").Value
'This brings up a 438 runtime error (object doesnt support this propery
or method)
a = ws.Range("J8:AN51").Comments
b = area.Range("E2:AI45").Comments
a = b
'area.Range("E2:AI45").Copy
'ws.Range("J8:AN51").PasteSpecial xlPasteComments
ws.Range("J62:AN63").Value = area1.Range("E47:AI48").Value
ws.Range("J55:AN55").Value = area.Range("E52:AI52").Value
I have checked on Google but it just keeps bringing up how to copy values within a cell, and what I am after is just the comments, (as the values are already copied)
My initial idea was to try to load all the comments in an VBA array and then use this comment array to write to the other worksheet.
So, I tried to adapt this technique from Chip Pearson's website that does exactly that but for cell values.
Unfortunatly, using .comment.text on a range with multiple cells won't return an array which means that this method won't work.
This means that in order to transfer the comments to the other sheet using VBA, you would need to go through all cells one by one in the range (as a collection perhaps). Although I'm sure this would work, it most likely won't be faster than using xlPasteComments.
I would then resolve to use the usual VBA techniques to make your macro run faster by deactivating certain settings like automatic calculation, screen updating and events. Here is an example of how I would implement it (including some error handling):
Sub Optimize_VBA_Performance_Example()
Const proc_name = "Optimize_VBA_Performance_Example"
'Store the initial setting to reset it at the end
Dim Initial_xlCalculation_Setting As Variant
Initial_xlCalculation_Setting = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayStatusBar = False
.EnableEvents = False
End With
On Error GoTo Error_handler
'Your code
'Restore initial settings (before exiting macro)
With Application
.Calculation = Initial_xlCalculation_Setting
.ScreenUpdating = True
.EnableEvents = True
.DisplayStatusBar = True
End With
Exit Sub
Error_handler:
'Restore initial settings (after error)
With Application
.Calculation = Initial_xlCalculation_Setting
.ScreenUpdating = True
.EnableEvents = True
.DisplayStatusBar = True
End With
'Display error message
Call MsgBox("Run-time error '" & Err.Number & "': " & Err.Description & vbNewLine & _
"While running: " & proc_name & vbNewLine, _
vbCritical, "Error")
End Sub
If you only care about the text of the comment (and not the formatting), you can use the Range.Comment.Text object to copy the comment text. The main difficulty arises in error handling whether or not the comment exists. Then just loop through all the cells in your source range and assign the comment to the destination range.
Sub copyComment(source As Range, dest As Range)
Dim t As String
' first set up error handling to exit the sub if the source cell doesn't have a comment
On Error GoTo ExitCopyComment
t = source.Comment.Text
' change error handling to go to next line
On Error Resume Next
' assign the text to an existing comment at the destination
' use this 1,1 offset (first cell in range) syntax to overcome parser
' issue about assignment to constant
dest(1, 1).Comment.Text = t
' if that produced an error then we need to add a comment
If (Err) Then
dest.AddComment t
End If
ExitCopyComment:
' clear error handling
On Error GoTo 0
End Sub
Sub test()
Dim cell As Range
Sheet1.Activate
' loop through all cells in source
For Each cell In Sheet1.Range("E47:AI48").Cells
' calculate destination range as offset from source cell
Call copyComment(cell, Sheet2.Cells(cell.Row + 15, cell.Column + 5))
Next cell
End Sub

Excel VBA - Insert Username ONLY when cell is changed

Here's my problem: I have working code to insert a username and timestamp when a user makes a change anywhere in a row. Great! So my code works and I answered my own question, right? Nope! There's a tiny issue which, while it doesn't break the code, does lead to a user having their username input as having made a change when a change was not made.
Here's my code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
ThisRow = Target.Row
'protect Header row from any changes
If (ThisRow = 1) Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
MsgBox "Header Row is Protected."
Exit Sub
End If
For i = 1 To 61
If Target.Column = i Then
' time stamp corresponding to cell's last update
Range("BK" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("BJ" & ThisRow).Value = Environ("username")
Range("BJ:BK").EntireColumn.AutoFit
End If
Next i
End Sub
Here's how it happens: A user decides they want to make a change to a cell, so they double click the cell. Now, if they push the escape key, nothing happens and everything is hunky dory. But, if they double click the cell, then click outside of the cell to another cell to leave that cell, the system logs that as a change even though no change was made and the user's username is put into column 62. This is no bueno, because someone could be held responsible for a mistake that another individual has made if they're incorrectly put down as the last person to change something in that row.
Conversely - it might be worthwhile to create a comment in a cell which is changed by a user, but I reckon I'd have the same issue with double-clicking a cell, so I'd still have to account for it.
Thoughts?
Edit: Full disclosure, I found this code elsewhere and adapted it to my purposes.
You can test to see if the old value and the new value are the same. I use "new" loosely, meaning excel things that the cell was edited so it's a "new" value in terms of the Worksheet_Change event understanding.
I also got rid of your For loop as it seemed very unnecessary. If I am mistaken, I apologize.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim ThisRow As Long ' make sure to declare all the variables and appropiate types
ThisRow = Target.Row
'protect Header row from any changes
If (ThisRow = 1) Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
MsgBox "Header Row is Protected."
Exit Sub
End If
If Target.Column >= 1 And Target.Column <= 61 Then
Dim sOld As String, sNew As String
sNew = Target.Value 'capture new value
With Application
.EnableEvents = False
.Undo
End With
sOld = Target.Value 'capture old value
Target.Value = sNew 'reset new value
If sOld <> sNew Then
' time stamp corresponding to cell's last update
Range("BK" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("BJ" & ThisRow).Value = Environ("username")
Range("BJ:BK").EntireColumn.AutoFit
End If
Application.EnableEvents = True
End If
End Sub

speed up Excel off-sheet dependents search

I've incorporated the off-sheet dependents search using the "ShowDependents" and "NavigateArrow" VBA methods. Everything works well but it is just painfully slow (for a large number of dependents).
Are there alternatives, way to speed it up? I've tried disabling the ScreenUpdating but that doesn't speed it up by much.
This is what my code is based on: http://www.technicana.com/vba-for-checking-dependencies-on-another-sheet
Consider the following function which is supposed to return true if the cell you pass it has a direct dependent on a different sheet:
Function LeadsOut(c As Range) As Boolean
Application.ScreenUpdating = False
Dim i As Long, target As Range
Dim ws As Worksheet
Set ws = ActiveSheet
c.ShowDependents
On Error GoTo return_false
i = 1
Do While True
Set target = c.NavigateArrow(False, i)
If c.Parent.Name <> target.Parent.Name Then
ws.Select
ActiveSheet.ClearArrows
Application.ScreenUpdating = True
LeadsOut = True
Exit Function
End If
i = i + 1
Loop
return_false:
LeadsOut = False
ActiveSheet.ClearArrows
Application.ScreenUpdating = True
End Function
Sub test()
MsgBox LeadsOut(Selection)
End Sub
To test it, I linked the test sub to a command button on Sheet1.
In A2 I entered the formula = A1 + 1, with no other formulas on Sheet1.
On Sheet2 I entered the formula =Sheet1!A2.
Back on Sheet1, if I select A2 and invoke the sub it almost instantly pops up "True". But if I select A1 and invoke the sub it returns "False" -- but only after a delay of several seconds.
To debug it, I put a Debug.Print i right before i = i + 1 in the loop. The Immediate Window, after running it again, looks like:
32764
32765
32766
32767
Weird!!!!!
I was utterly stumped until I replaced Debug.Print i by
Debug.Print target.Address(External:=True)
Which led to output that looks ends like:
[dependents.xlsm]Sheet1!$A$1
[dependents.xlsm]Sheet1!$A$1
[dependents.xlsm]Sheet1!$A$1
[dependents.xlsm]Sheet1!$A$1
NavigateArrow(False,i) goes back to the originating cell and stays there once i exceeds the number of dependents! This is seemingly undocumented and massively annoying. The code you linked to was written by someone who hasn't discovered this. As a kludge, you should check that when you are navigating arrows you haven't returned to the starting point. The following seems to work almost instantly in all cases, although I haven't tested it very much:
Function LeadsOut(c As Range) As Boolean
Application.ScreenUpdating = False
Dim i As Long, target As Range
Dim ws As Worksheet
Set ws = ActiveSheet
c.ShowDependents
On Error GoTo return_false
i = 1
Do While True
Set target = c.NavigateArrow(False, i)
If target.Address(External:=True) = c.Address(External:=True) Then
GoTo return_false
End If
If c.Parent.Name <> target.Parent.Name Then
ws.Select
ActiveSheet.ClearArrows
Application.ScreenUpdating = True
LeadsOut = True
Exit Function
End If
i = i + 1
Loop
return_false:
LeadsOut = False
ActiveSheet.ClearArrows
Application.ScreenUpdating = True
End Function
The key lines are the three lines which begin
If target.Address(External:=True) = c.Address(External:=True)
Adding some such check in the sub you linked to should make a massive difference.

excel vba created active x button missing text until moved in design mode

So I had everything working in my giant excel project until today. I have a very large project of code that I'm running on a multitude of sheets within a large group of workbooks. Part of this code makes buttons as needed. I edited some unrelated range formats to sheets and when I ran my code, one of my 3 button creation processes created buttons that appear to have no Caption. However, when I enter design mode and move those buttons, the text appears (I was trying to look at the properties when I found this out). All of the buttons have valid values for their caption, but none of them are actually being displayed until manually moved and then moved back. Considering there are ~ 10,000 of these buttons between all the workbooks, this is a problematic manual process. (luckily I haven't run the code on all the workbooks yet)
I can't for the life of me figure out why these buttons are having this happen, but it is now a consistent behavior. The other active x buttons are not having the same problem.
Here is the code for an active x button that works:
Sub AddNAMEButton(tc As Range, Sht As Worksheet)
Dim NewButton As OLEObject
Dim ButtonExist As Boolean
Dim ButtonName As String
ButtonExist = False
ButtonName = Sht.Name & tc.Row & "NAME"
With Sht
On Error Resume Next
ButtonName = Sht.OLEObjects(ButtonName)
If ButtonName <> "" Then
ButtonExist = True
Else
ButtonExist = False
End If
If ButtonExist = True Then
Sht.OLEObjects(ButtonName).Delete
GoTo CreateButton
On Error GoTo 0
Else
GoTo CreateButton
On Error GoTo 0
End If
End With
CreateButton:
With tc.Cells(1, 6)
Set NewButton = Sht.OLEObjects.Add _
(ClassType:="Forms.CommandButton.1", _
Link:=False, DisplayAsIcon:=False, _
Left:=.Left, _
Top:=.Top, _
Height:=.Height, _
Width:=.Width)
NewButton.Object.Caption = "NAME"
NewButton.Object.Font.Size = 9
NewButton.Object.Font.Bold = True
NewButton.Name = Sht.Name & .Row & "NAME"
NewButton.Object.Font.Name = "Arial"
NewButton.Placement = xlMoveAndSize
End With
End Sub
And here is the code of the problematic button:
Sub AddAppButton(tc As Range, Sht As Worksheet)
Dim NewButton As OLEObject
Dim ButtonExist As Boolean
Dim ButtonName As String
ButtonExist = False
ButtonName = Sht.Name & tc.Row & "App"
With Sht
On Error Resume Next
ButtonName = Sht.OLEObjects(ButtonName)
If ButtonName <> "" Then
ButtonExist = True
Else
ButtonExist = False
End If
If ButtonExist = True Then
Sht.OLEObjects(ButtonName).Delete
GoTo CreateButton
On Error GoTo 0
Else
GoTo CreateButton
On Error GoTo 0
End If
End With
CreateButton:
With tc.Cells(1, 8)
Set NewButton = Sht.OLEObjects.Add _
(ClassType:="Forms.CommandButton.1", _
Link:=False, DisplayAsIcon:=False, _
Left:=.Left, _
Top:=.Top, _
Height:=.Height, _
Width:=.Width)
NewButton.Object.Caption = "App"
NewButton.Object.Font.Size = 9
NewButton.Object.Font.Bold = True
NewButton.Name = Sht.Name & .Row & "App"
NewButton.Object.Font.Name = "Arial"
NewButton.Placement = xlMoveAndSize
End With
End Sub
In the code that calls these, they are called right next to each other:
Call Module3.AddAppButton(tc, Sht)
Call Module3.AddNAMEButton(tc, Sht)
That's part of 6 different button creation calls (2 before them and 2 after) and all of those other 4 active x buttons are working fine. Just the App button is having the problem. I've tried a few things now, changing that buttons default location on the worksheet, editing those button's formatting after the final sheet formatting, etc. Nothing has worked. I cannot for the life of me figure out what would be the difference between the two processes I posted (other than name), and I also can't figure out why the value of the caption is on the button, but is not being displayed on the button until the button is moved on the sheet.
Before anyone recommends not working with active x buttons, I also have other form types and all of the OLEObject types need to be maintained as that type so that when other processes run, they can manipulate all of the like-typed of objects (all OLEObjects are the same context while other form types have other contexts). So it's much more complicated than just "don't work with active x buttons!" as them being active x buttons is serving a specific purpose.
Copying the code I'm posting into a new worksheet results in buttons that are not broken, so I already assume that there's something else really weird going on, but I'm posting this hoping that someone has run into something similar and might be able to help figure out what's breaking in my document display (it really does seem like just a display issue, albeit one which cripples the excel app).
Thanks for any help!
This turns out to not be code related, but is instead an issue when creating a button on a sheet with hidden rows/columns. It may not be a simple as that, but I was able to resolve this just by putting a Sht.Rows.Hidden = False and Sht.Columns.Hidden = False before the CreateButton code. This resolved the issue entirely.
I suspect there is some sort of issue within excel and addressing point offset properties like "top" and "left" when something is being referenced in relation to (after, touching, something) hidden rows/columns. I'd dig into it more to figure out exactly why this happens, but I've got other work to do.