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
Related
Sub History1()
'
' History Macro
'
'
Dim sDate As String
Application.ScreenUpdating = False
sDate = Sheets("Summary").Range("P1").Value
If Not WorksheetExists(sDate) Then
Sheets.Add.Name = sDate
End If
Sheets(sDate).Visible = True
Sheets(sDate).Cells.UnMerge
Sheets("Summary").Range("A1:Z100").Select
Selection.Copy
Sheets(sDate).Range("A1:Z100").Select
Selection.Paste
Sheets(sDate).Visible = False
Sheets("Summary").Cells(3, 1).Select
Application.ScreenUpdating = True
' MsgBox ("Done")
End Sub
The value in sDate is the string 05_14_21 and works fine when used earlier in the sub. The first instance of Range.Select operation works fine, at least I think it does. No error generated. The second one says "Select method of Range class failed". The worksheet "05_14_21" is visible at the time of the 2nd operation. I am at a loss. Any insights will be appreciated.Th
You cant use .Select on a range of a sheet that isn't active. It will give you Run-Time Error 1004. The fix would be to first select that sheet, then select the range. But honestly, using .Select is unnecessary and will make the screen jitter around while the macro is running. .Select also slows down your macro, which becomes very noticeable when you start using loops in your code.
Instead I would suggest directly referencing your ranges instead of using .Select like so:
Sub History1()
Dim sDate As String
Application.ScreenUpdating = False
sDate = Sheets("Summary").Range("P1").Value
If Not WorksheetExists(sDate) Then
Sheets.Add.Name = sDate
End If
Sheets(sDate).Visible = True
Sheets(sDate).Cells.UnMerge
Sheets("Summary").Range("A1:Z100").Copy Destination:= Sheets(sDate).Range("A1:Z100")
Sheets(sDate).Visible = False
Application.ScreenUpdating = True
' MsgBox ("Done")
End Sub
I am not sure why you need to select Cells(3,1), but in order to do that you need to activate the correct sheet. As pointed out in another answer, using select is not advisable. This also results in a more concise way to copy and paste.
Dim sDate As String
Application.ScreenUpdating = False
sDate = Sheets("Summary").Range("A1").Value
If WorksheetExists(sDate) = False Then
Sheets.Add.Name = sDate
End If
Sheets(sDate).Visible = True
Sheets(sDate).Cells.UnMerge
Sheets("Summary").Range("A1:Z100").Copy _
Destination:=Sheets(sDate).Range("A1:Z100")
Sheets(sDate).Visible = False
Sheets("summary").Activate
Sheets("Summary").Cells(3, 1).Select
Application.ScreenUpdating = True
I made a macro that take data from closed workbook but unfortunately the code runs too slowly for me.
Just when i start the macro it loading around 2 or 3 second. I will be very thankful if you help me to optimize the code :
Hire is my code:
Sub Button4_Click()
Dim SRC As Workbook
Application.ScreenUpdating = False
Set SRC = Workbooks.Open("C:\Users\a1068434\Desktop\TEST\asdasd.CSV", True, True)
ActiveWindow.Visible = False
ThisWorkbook.Activate
Dim R As Range
Set R = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp) 'last cell in Column A with data
If Len(R.Value) > 0 Then Set R = R.Offset(1)
R.Value = SRC.Worksheets("asdasd").Range("G14").Formula
SRC.Close SaveChanges:=False
End Sub
Since your working with csv and just pulling but one value out of it, why not parse the text?
Private Sub Button4_Click()
On Error GoTo Wrapup
Application.ScreenUpdating = False
Open "C:\Users\a1068434\Desktop\TEST\asdasd.CSV" For Input As #1
'skip to line 14
For i = 1 To 14
Line Input #1, LineFromFile
Next i
'read in the 7th column
LineItems = Split(LineFromFile, ",")
result = LineItems(6)
'Output
Dim R As Range
Set R = Worksheets("asdasd").Cells(Rows.Count, 1).End(xlUp)
If Len(R.Value) > 0 Then Set R = R.Offset(1)
R.Value = result
Wrapup:
Close #1
Application.ScreenUpdating = True
End Sub
Nothing will make Excel open/close a workbook faster, other than getting a faster hard drive and opening/closing smaller files.
There are a number of ways your code can be improved though, notably:
Using explicit access modifiers. Click handlers have no reason to be implicitly public
Code that toggles off ScreenUpdating should always toggle it back on whether there's an error or not
Getting the Len of a Variant with an unknown subtype is dangerous: you never know if you're going to hit a Variant/Error, and Len(CVErr(xlErrNA)) throws a type mismatch error and you don't want that. So, verify whether the value IsError first.
You never (99.99999% accurate) need to Activate anything. Worksheets that exist in ThisWorkbook at compile-time can (should) be accessed by their code name identifier.
Private Sub Button4_Click()
On Error GoTo CleanFail
Application.ScreenUpdating = False
Const path As String = "C:\Users\a1068434\Desktop\TEST\asdasd.CSV"
Dim source As Workbook
Set source = Application.Workbooks.Open(path, True, True)
ActiveWindow.Visible = False '<~ why bother?
Dim lastCellWithData As Range '<~ no need for comments when names are descriptive
Set lastCellWithData = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp)
If Not IsError(lastCellWithData.Value) Then
Dim lastCellStringValue As String
lastCellStringValue = lastCellWithData.Value
If Len(lastCellStringValue) > 0 Then
lastCellWithData.Offset(1).Value = source.Worksheets("asdasd").Range("G14").Formula '<~ do you really mean .Formula?
End If
End If
CleanExit:
source.Close SaveChanges:=False
Application.ScreenUpdating = True
Exit Sub
CleanFail:
Debug.Print Err.Description
Resume CleanExit
Resume '<~ for step-through debugging; make this the next stmt to highlight the error statement
End Sub
I have a formula that makes an API request every time it's executed, which makes it slow. I'd like to prevent Excel from automatically recalculating cells containing this formula but still automatically recalculate other cells.
I've tried setting calculation mode to Manual with:
Application.Calculation = xlCalculationManual
However this prevents other cells without my formula from calculating automatically.
Another idea I've had is to check if a cell has been "frozen" and then return it's current value instead of calling the API for a new value. The issue with this is that Excel doesn't provide a way to exit the function without altering the cell value.
Function MyFormula() As Variant
If CellIsFrozen() Then
MyFormula = Application.Caller.Value 'return current value
Else
MyFormula = GetNewValueFromAPI() 'expensive call to server
End If
End Function
My issue with the above is that Application.Caller.Value returns the cell value by performing a recalculation and results in an infinite recursion.
FYI - the CellIsFrozen method is just an example sub that would somehow check whether the cell was called automatically or manually.
I'm also aware of Application.Caller.Value2 and .text, unfortunately these don't help me. Value2 also causes a recalculation, and text just returns a string representation (which is not useful because it could be "######" if the value is a date and the column is too narrow).
Is there a way to interrupt Excel's recalculation process for specific formulas?
Otherwise, is it possible to extract a value of a cell without performing a recalculation - I'm guessing that Excel stores the value somewhere because it's visible on the worksheet, it makes no sense to insist on recalculating every time.
In the context my previous answer to the post involving single cell, i also want share our old experience involving multiple cells. that days We used the formula in an indexed fashion like =myformula(1)... etc and stored it in a global array. Now today thanks to your great idea of Caller function. I recreated another improvised solution involving multiple cells.
Here again in module1
Global Flag As Boolean, LastValArr(1 To 10, 1 To 2) As Variant, Ws As Worksheet, Rng As Range
Public Function MyFormula() As Variant
Dim Adr As String, X As Integer
If Flag Then
MyFormula = GetNewValueFromAPI() 'expensive call to server
Else
Adr = Application.Caller.Address
For X = 1 To 10
If InStr(1, LastValArr(X, 2), Adr) > 0 Then
MyFormula = LastValArr(X, 1)
Exit For
End If
Next
End If
End Function
Function GetNewValueFromAPI() As Variant
GetNewValueFromAPI = Application.WorksheetFunction.RandBetween(1, 1000)
End Function
Sub CalcA1()
Flag = True
Rng.Dirty
Flag = False
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
End Sub
Sub ToggleFlag()
Flag = Not Flag
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
If Flag Then Rng.Dirty
End Sub
in Workbook_Open event
Private Sub Workbook_Open()
Dim X As Integer
Dim Cell As Range
Set Ws = ThisWorkbook.Sheets("Sheet1")
Set Rng = Ws.Range("A1:A5")
Set Rng = Union(Rng, Ws.Range("C1:C5"))
Flag = True
Rng.Dirty
Flag = False
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
End Sub
in Sheet1 Worksheet_Calculate event
Private Sub Worksheet_Calculate()
Dim X As Integer
Dim Cell As Range
X = 1
For Each Cell In Rng.Cells
LastValArr(X, 1) = Cell.Value
LastValArr(X, 2) = Cell.Address
X = X + 1
Next
End Sub
Edit: On second thought after initial feel good of posting the Demo answer, I found it lacks User friendliness and ease of copy pasting UDF formulas while working in Excel Therefore i tried improvise it further so it could be used by users don't have access to VBA code and could work with copy paste of the UDF.
So 1st I came across a solution to store the Last Values in a temp sheet (may be Very Hidden Sheet). with apprehension that working with cell access may degrade performance of the code, I refrained from posting it and I finally restored to Dictionary Object.
This solution have added with basic advantage of Auto mapping of formula cells (by searching "=myformula" in used range of the Sheet) to enable/disable calculation. This would enable users without access to code modules to work freely with UDF.
Here reference to Microsoft scripting runtime has been added.
Code in module:
Global Flag As Boolean, Ws As Worksheet, Rng As Range, Dict As Dictionary
Public Function MyFormula() As Variant
Dim Adr As String
If Flag Then
MyFormula = GetNewValueFromAPI() 'expensive call to server
Else
Adr = Application.Caller.Address
'Debug.Print Adr
MyFormula = IIf(Dict.Exists(Adr), Dict(Adr), 0)
End If
End Function
Function GetNewValueFromAPI() As Variant
'Delay (2)
GetNewValueFromAPI = Application.WorksheetFunction.RandBetween(1, 1000)
End Function
Sub CalcA1()
Flag = True
If Not Rng Is Nothing Then Rng.Dirty
'Debug.Print "in calA1"
Flag = False
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
End Sub
Sub ToggleFlag()
Flag = Not Flag
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
If Flag And Not Rng Is Nothing Then Rng.Dirty
End Sub
Sub BuildRange()
Application.EnableEvents = False
Dim Cell As Range
CalcCnt = CalcCnt + 1
Set Rng = Nothing
Dict.RemoveAll
For Each Cell In Ws.UsedRange.Cells
If Left(Cell.Formula, 10) = "=myformula" Then
'Debug.Print "From Sht Calc -" & Cell.Address
If Dict.Exists(Cell.Address) = False Then
Dict.Add Cell.Address, Cell.Value
Else
Dict(Cell.Address) = Cell.Value
End If
If Rng Is Nothing Then
Set Rng = Cell
Else
Set Rng = Union(Rng, Cell)
End If
End If
Next
Application.EnableEvents = True
End Sub
In Workbook_Open
Private Sub Workbook_Open()
'Dim X As Integer
Dim Cell As Range
Set Ws = ThisWorkbook.Sheets("Sheet1")
Set Dict = New Dictionary
Flag = True
BuildRange
If Not Rng Is Nothing Then Rng.Dirty
Flag = False
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
End Sub
In Sheet Calculate event
Private Sub Worksheet_Calculate()
BuildRange
End Sub
If you are using an UDF in the cell, I will like to make it like this workaround.
For demo and test, Only used a single cell A1 in "Sheet1" , instead of using any API, I used WorksheetFunction.RandomBetween May use range and array if multiple cells are used.
In "Sheet1" cell A1 used =myFormula()
in a module
Public Flag As Boolean, LastVal As Variant
Public Function MyFormula() As Variant
If Flag Then
MyFormula = GetNewValueFromAPI() 'expensive call to server
Else
MyFormula = LastVal
End If
End Function
Function GetNewValueFromAPI() As Variant
GetNewValueFromAPI = Application.WorksheetFunction.RandBetween(1, 1000)
End Function
Sub CalcA1 in Module1 would be used to recalculate A1 whenever necessary. It could be called from any events also according to actual requirement.
Sub CalcA1()
Flag = True
Worksheets("Sheet1").Range("A1").Dirty
Flag = False
End Sub
In workbook Open event the the LastVal was calculated with Flag as true and then Flag was reset to false to prevent further calling GetNewValueFromAPI
Private Sub Workbook_Open()
Flag = True
Worksheets("Sheet1").Range("A1").Dirty
LastVal = Worksheets("Sheet1").Range("A1").Value
Flag = False
End Sub
In Worksheet_Calculate event of Sheet1 the LastVal is being recorded.
Private Sub Worksheet_Calculate()
LastVal = Worksheets("Sheet1").Range("A1").Value
End Sub
Working Demo
Regret, I came across this post (A Real Good Question) late, since We had already been used something in this line in our workplace. Thanks to #Pawel Czyz for editing the post it came under Active List today only.
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
I'm using this formula to delete empty columns in my sheet. But it takes around 15-20min to delete them. Can I somehow speed up this proces? It's weird that it takes so long and I'm only working with 100 columns.
For j = 1 To 5
For i = 40 To 146
If Sheet8.cells(4, i) = "" Then
Columns(i).EntireColumn.Delete
End If
Next i
Next j
If you have real bank cells use #Patrick Honorez answer using SpecialCells(xlCellTypeBlanks) which is faster.
But if you have no real blank cells (eg formulas that show as "") then you can use this:
Dim DeleteRange As Range
With sheet8
Dim i As Long
For i = 40 To 146
If .Cells(4, i).Value = vbNullString Then 'vbNullString = ""
If DeleteRange Is Nothing Then
Set DeleteRange = .Columns(i)
Else
Set DeleteRange = Union(DeleteRange, .Columns(i))
End If
End If
Next i
End With
If Not DeleteRange Is Nothing Then 'check if there is something to delete
DeleteRange.EntireColumn.Delete
End If
It collects all columns that you want to delete in DeleteRange and then deletes them at once. This is faster than deleting each column on its own, because each delete action needs its time (and here we have only one delete action).
Note that we don't need to loop backwards here because we only collect the columns within the loop but delete action comes after the loop, so it doesn't affect the loop counting at all.
Try:
For i = 146 To 40 step -1
If Sheet8.cells(4, i) = "" Then
Columns(i).EntireColumn.Delete
End If
Next i
Try adjusting this for your needs. I think nothing can go faster :-)
Sub test()
Range("C3:j17").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
End Sub
I would suggest to do it like that.
Option Explicit
Private Sub TurnOffFunctionality()
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
End Sub
Private Sub TurnOnFunctionality()
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub TestIt()
Dim i As Long
TurnOffFunctionality
For i = 146 To 40 Step -1
If Sheet8.Cells(4, i) = "" Then
Columns(i).EntireColumn.Delete
End If
Next i
TurnOnFunctionality
End Sub
Turning off especially re-calculation will make sure that a re-caculation is not triggered with every deletion of a single column in the loop. This could probably be the cause of the long run time.