The purpose of the macro is to avoid creating a new worksheet each time a user double clicks / drills down on a pivot table value. Instead the script copies the data to a dedicated "DrillDown" sheet.
After several clicks, I get an Excel error stating I am out of memory.
The raw dataset is not very big.
I am wondering if there is an issue with the script, or perhaps I need to add something further?
Maybe there is some temp data I need to clear first?
My code:
Module1
Public CS$
This Workbook
Private Sub Workbook_NewSheet(ByVal Sh As Object)
If CS <> "" Then
With Application
ScreenUpdating = False
Dim NR&
With Sheets("DrillDown")
'Set this to always start at the top of the page
NR = 1
'..and to clear the Drilldown tab..
.Cells.ClearContents
'instead of this..
'If WorksheetFunction.CountA(.Rows(1)) = 0 Then
' NR = 1
'Else
' NR = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 2
'End If
Range("A4").CurrentRegion.Copy .Cells(NR, 1)
End With
.DisplayAlerts = False
ActiveSheet.Delete
.DisplayAlerts = True
'Below is commented out to stop user being returned to Pivot
' Sheets(CS).Select
.ScreenUpdating = True
End With
End If
End Sub
It could be the event triggers while the data is still being written to the sheet. You could retain the newly created sheet and delete the previous to avoid copying.
Private Sub Workbook_NewSheet(ByVal Sh As Object)
If CS = "" Then Exit Sub
With Application
.DisplayAlerts = False
On Error Resume Next
Sheets("DrillDown").Delete
Sh.Name = "DrillDown" ' renamenew sheet
On Error GoTo 0
.DisplayAlerts = True
End With
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
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