I'm doing some automation in Excel with VBA. We have several versions of a template and I'm working on functionality that allows users to import data from older versions into the newest version of the template.
Here's some of that code:
If .Range("E63").Interior.Color <> .Range("M5").Interior.Color Then
Call switch
.Range("E63:E142").Value = PTWorkbook.Sheets("Configuration").Range("E63:E142").Value
Call switch
...
The switch sub swaps two the columns in the new template to properly line them up so we can import from the old template more easily. The issue is that that sub doesn't run unless I step through the sub in debug mode. The values get imported into the template, but the columns don't switch like they're supposed to.
Sub switch()
Dim inputValue As Variant
Dim calculatedValue As Variant
If Range("F63").Interior.Color = Range("M5").Interior.Color Then
inputValue = "F"
calculatedValue = "E"
Else
inputValue = "E"
calculatedValue = "F"
End If
Range(calculatedValue & "63:" & calculatedValue & "142").Formula = Range(calculatedValue & "63:" & calculatedValue & "142").Value
Range(inputValue & "63").Formula = "=" & calculatedValue & "63"
If inputValue = "F" Then
Range(inputValue & "64:" & inputValue & "98").Formula = "=" & calculatedValue & "64-" & calculatedValue & "63"
Else
Range(inputValue & "64:" & inputValue & "98").Formula = "=" & calculatedValue & "64+" & inputValue & "63"
End If
Range(inputValue & "63:" & inputValue & "142").Interior.Color = Range("M13").Interior.Color
Range(calculatedValue & "63:" & calculatedValue & "142").Interior.Color = Range("M5").Interior.Color
End Sub
I did some research and a lot of people recommend putting DoEvents after the call to 'slow things down' and effectively wait for the sub to finish. But that hasn't worked.
I also have almost identical code elsewhere that does the exact same thing, but from a different version, and it works with the DoEvents call.
Does anyone know what might be going wrong here?
Edit:
Added switch sub.
Related
I have come across a strange behavior while writing code to update custom number in footer through VBA. I am using Excel 365.
Objective: To write custom page numbers to each sheet.
I have written below code which works to an extent.
Sub TestHdrFooter()
Dim wksCurr As Worksheet
Dim lngPageBase As Long, lngShtLen As Long
Dim strBaseDocNumb As String, strRev As String, strExpr As String
lngPageBase = 2
strBaseDocNumb = "DOC-99-100000-AA-9999-99999"
strRev = "01"
lngShtLen = Len("0005")
For i = 1 To ThisWorkbook.Sheets.Count
Set wksCurr = ThisWorkbook.Sheets(i)
With wksCurr.PageSetup
'\\ Reset footer if something has been accidentally entered
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
If Len(CStr(lngPageBase)) = 1 Then
.RightFooter = strBaseDocNumb & "-" & Application.Rept("0", lngShtLen - 1) & " &[Page]+" & lngPageBase & "-" & strRev
Else
.RightFooter = strBaseDocNumb & "-" & Application.Rept("0", lngShtLen - 2) & " &[Page]+" & lngPageBase & "-" & strRev
End If
lngPageBase = lngPageBase + .Pages.Count
End With
Next i
End Sub
However, it doesn't update correctly directly as when I open it through Page Setup>>Header/Footer I see it appears as below without the opening bracket which is available in the code.
Then comes the stranger part. When I open the "custom Footer" dialog on the form, it shows the missing bracket and then simply pressing "OK" when closing this dialog updates everything correctly without having to change anything! I am not able to guess the reason for this behavior.
Questions:
Is there anything wrong with my VBA code that needs to be amended?
Is there any way to force refreshing the expression that appears in second screenshoot if code is correct?
I should've read Microsoft's documentation before posting the question. My code expression while it appears correct literally, it isn't the proper way to use it through VBA.
Incorrect expression:
.RightFooter = strBaseDocNumb & "-" & Application.Rept("0", lngShtLen - 1) & " &[Page]+" & lngPageBase & "-" & strRev
Correct expression:
.RightFooter = strBaseDocNumb & "-" & Application.Rept("0", lngShtLen - 1) & "&P+" & lngPageBase & "-" & strRev
Notice the change in Page part. This is clearly mentioned in MS Documentation.
https://learn.microsoft.com/en-us/previous-versions/office/developer/office-2007/bb225426(v=office.12)?redirectedfrom=MSDN
I am automating a report, and the hierarchy is always subject to change. Since people who will be using this macro have no coding skills I have been creating a new report. But recently I got stuck on this part. I have a sheet where the user can enter the hierarchy. Then the code loops through the hierarchy added and saves it in a method that I thought would work in an array. It will run but when it gets to the filter part I get the error: The object invoked has disconnected from its clients
I originally had the hierarchy in the code before but I do not want the users to touch the code. When it was in the code It worked perfectly. The way I am doing it now appears to match what I had done before but am once again having issues
Private Sub CommandButton1_Click()
Set wa = ThisWorkbook.Worksheets("Sheet2")
Set wt = ThisWorkbook.Worksheets("Sheet1")
lastrow = wa.Cells(Rows.Count, 1).End(xlUp).Row
lastrow99 = wt.Cells(Rows.Count, 1).End(xlUp).Row
For Each a In wt.Range("A2:A" & lastrow99)
If IMRCCSpec1 = Empty Then
IMRCCSpec1 = a.Cells.Value
Else
IMRCCSpec1 = IMRCCSpec1 & """" & ", " & """" & a.Cells.Value
End If
Next a
lastrow99 = wt.Cells(Rows.Count, 2).End(xlUp).Row
For Each a In wt.Range("B2:B" & lastrow99)
If IMRCCSup1 = Empty Then
IMRCCSup1 = a.Cells.Value
Else
IMRCCSup1 = IMRCCSup1 & """" & ", " & """" & a.Cells.Value
End If
Next a
IMRRCCSpec = Array(IMRCCSpec1)
IMRRCCSup = Array(IMRCCSup1)
wa.Range("A1:U" & lastrow).Sort Key1:=wa.Range("D1:D" & lastrow), Order1:=xlAscending, Header:=xlYes
wa.Range("A1:U" & lastrow).AutoFilter field:=6, Criteria1:=IMRCCSpec, Operator:=xlFilterValues
End Sub
I would like for the the code to actually filter based on what the hierarchy is
I have the following function which I use to fetch data from a closed workbook:
Public Function GetValue(path, file, sheet, ref)
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Then I have the following test routine which works:
Sub TestGetValue()
p = Range("B2").Value
f = Range("B3").Value
s = "TOTAL"
a = "D" & ActiveCell.Row + 3
MsgBox GetValue(p, f, s, a)
End Sub
However, if I use the GetValue function in an Excel cell providing all 4 parameters exactly like in the routine, it always throws a #VALUE! error.
Why does it work in a routine and not while being called as a function?
After several attempts I did find 3 solutions:
Using a function with "ExecuteExcel4Macro"
Opening the other workbook in the background by vba procedure, then copy/pasting data
Creating external references by vba procedure, then leaving only values
First one while being able to use it as an excel custom formula, it is the slowest, especially when you need data from a specific range. So I don't recommend this option as it would slow your workbook down a lot.
Second option while being much faster, still takes around 15 seconds to get data from several ranges across 2 workbooks.
Third option was the fastest. Like an instant really less than 1 second execution time during which data was pulled from 2 closed workbooks and for different ranges.
Here's the 3rd option's procedure:
Sub getDS()
asname = "data"
bsname = "Anual"
csname = "Total"
filename = Sheets("data").Range("B64").Value
path = Sheets("data").Range("B63").Value
Dim ws As Worksheet
Set ws = Sheets("data")
With ws.Range("D4:D34")
.ClearContents
.Formula = "='" & path & "[" & filename & "]" & bsname & "'!R11"
.Value = .Value
End With
With ws.Range("J4:J34")
.ClearContents
.Formula = "='" & path & "[" & filename & "]" & bsname & "'!U11"
.Value = .Value
End With
With ws.Range("J37:J37")
.ClearContents
.Formula = "='" & path & "[" & filename & "]" & csname & "'!DW96"
.Value = .Value
End With
End Sub
I found this by far to be the BEST and FASTEST VBA solution to fetch data in an INSTANT from closed workbooks (with variables) without opening them.
So, I have Googled about and it seems that while making custom Pop up menus, if one wants to pass parameters then this is possible but for me comes with 2 major problems:
1) The function you call will execute, but you will not be able to activate a breakpoint on it, or even use Stop.
2) Oddly it seems to get called twice, which isn't very helpful either.
Code to illustrate ( please put in a module and not in a sheet )
Option Explicit
Sub AssignIt()
Dim cbrCmdBar As CommandBar
Dim strCBarName As String
On Error Resume Next
strCBarName = "MyNewPopupMenu"
'Delete it first so multiple runs can occur without appending
Application.CommandBars(strCBarName).Delete
' Create a menu bar.
Set cbrCmdBar = Application.CommandBars.Add(Name:=strCBarName, Position:=msoBarMenuBar)
' Create a pop-up menu.
strCBarName = "MyNewPopupMenu"
Set cbrCmdBar = Application.CommandBars.Add(Name:=strCBarName, Position:=msoBarPopup)
'DEFINE COMMAND BAR CONTROL
With Application.CommandBars(strCBarName).Controls.Add(Type:=msoControlButton)
.Caption = "MyMenu"
.OnAction = BuildProcArgString("MyProc", "A", "B", "C") 'You can add any number of arguments here!
End With
'DEFINE COMMAND BAR CONTROL
With Application.CommandBars(strCBarName).Controls.Add(Type:=msoControlButton)
.Caption = "Test No Args"
.OnAction = "CallWithNoArgs"
End With
Application.CommandBars(strCBarName).ShowPopup
End Sub
Sub CallWithNoArgs()
MsgBox "No Args"
End Sub
'FUNCTION TO BUILD PROCEDURE ARGUMENTS (You just have to plop this in any of your modules)
Function BuildProcArgString(ByVal ProcName As String, ParamArray Args() As Variant)
Dim TempArg
Dim Temp
For Each TempArg In Args
Temp = Temp + Chr(34) + TempArg + Chr(34) + ","
Next
BuildProcArgString = ProcName + "(" + Left(Temp, Len(Temp) - 1) + ")"
End Function
'AND FINALLY - THE EXECUTABLE PROCEDURE!
Sub MyProc(x, y, z)
MsgBox x & y & z
Debug.Print "arrgggh why won't the breakpoint work, and why call twice!!!!!!"
End Sub
If someone could help with this, that would be great. It seems another developer in the past hit the wall and so for the 5 items we have Method_1 ... Method_5 with the number passed into Method_Core(ByVal i As Integer) style. I think I will take this route too although very ugly, it works better than what I have mocked up below.
PS. This is a quick mockup so I don't expose proprietary code etc
You can use the .Parameter property. This is an example of a code in production (with only the lines of interest):
Dim i As Integer
Set cl = MainForm.Controls("classroomList")
For i = 0 To cl.ListCount - 1
With .Controls.Add(Type:=msoControlButton)
.Caption = cl.List(i)
.faceId = 177
.OnAction = "'" & ThisWorkbook.Name & "'!" & "assignClassroom"
.Parameter = cl.List(i)
End With
Next i
And the procedure could be something like:
Public Sub assignClassroom(Optional someArg as SomeType)
' code here
CommandBars.ActionControl.Parameter 'The parameter here
' more code here
End Sub
Don't ask me why this works, but it does. Source for this info is Using procedures with arguments in non-obvious instances
Sub AssignIt()
Const strCBarName As String = "MyNewPopupMenu"
Dim cbrCmdBar As CommandBar
'Delete it first so multiple runs can occur without appending
On Error Resume Next
Application.CommandBars(strCBarName).Delete
On Error GoTo 0
' Create a pop-up menu.
Set cbrCmdBar = Application.CommandBars.Add(Name:=strCBarName, Position:=msoBarPopup)
'DEFINE COMMAND BAR CONTROL
With Application.CommandBars(strCBarName).Controls.Add(Type:=msoControlButton)
.Caption = "MyMenu"
.OnAction = "'MyProc ""A"",""B"",2'"
End With
Application.CommandBars(strCBarName).ShowPopup
End Sub
Sub MyProc(x As String, y As String, z As Integer)
MsgBox x & y & (z * 2)
Debug.Print "AHA!!! the breakpoint works, and it's only called once!!!!!!"
End Sub
The key is to call the procedure in the .OnAction event surrounded by single quotes. Also, you need to escape your double quotes with double quotes. Numeric parameters need not be escaped.
The reason there are double calls and no break points is because of the parentheses (“( )”) surrounding the arguments in the .OnAction call:
.OnAction = BuildProcArgString("MyProc", "A", "B", "C")
Best guess: The parser for .OnAction chokes when these parentheses are used.
This should work:
.OnAction = "'BuildProcArgString" & chr(34) & "MyProc" & _
chr(34) & "," & chr(34) & "A" & chr(34) & "," & chr(34) & _
"B" & chr(34) & "," & chr(34) & "C" & "'"
Other Notes:
1) Single quotes, after the first double quote and before the last double quote, should be used to encapsulate the entire call.
2) Chr(34) is the ASCII character for double quotes (“). All data types (ints, longs, strings, etc.), and quoted commas need to be preceeded by a Chr(34). The one exception is the ending sinlge quote (" ' "). Example:
.OnAction = "'m_Test" & Chr(34) & 100 & Chr(34) & "," & Chr(34) & _
intVariable & Chr(34) & "," & Chr(34) & "String" & Chr(34) & _
"," & Chr(34) & stringVariable & "'"
The function called:
Public Function m_Test(i as Integer, iVar as Integer, s as String, sVar as String)
3) .OnAction does not seem to pass Arrays or Objects. An item in an array can be passed (e.g. .OnAction = "'myTest" & Chr (34) & Args(0) & "'"), but not the entire Array (e.g. .OnAction = "'myTest" & Chr (34) & Args & "'"). Object pointers can be passed (ref: http://www.access-programmers.co.uk/forums/showthread.php?t=225415). But I've had no success in passing pointers to arrays.
4) The .OnAction used in the original example is not surrounded by quotation marks so the .OnAction call is made when AssignIt() gets called but before the popup menu pops up.
I have a simple script that monitors processes' different performance statistics in Windows XP in a loop until it is terminated.
Despite my efforts, the script's memory footprint increases in size over time.
Any advice is greatly appreciated.
Set fso = CreateObject("Scripting.FileSystemObject")
logFileDirectory = "C:\POSrewrite\data\logs"
Dim output
Dim filePath
filePath = "\SCOPerformance-" & Day(Now()) & Month(Now()) & Year(Now()) & ".log"
IF fso.FolderExists(logFileDirectory) THEN
ELSE
Set objFolder = fso.CreateFolder(logFileDirectory)
END IF
logFilePath = logFileDirectory + filePath + ""
IF (fso.FileExists(logFilePath)) THEN
set logFile = fso.OpenTextFile(logFilePath, 8, True)
output = VBNewLine
output = output & (FormatDateTime(Now()) + " Open log file." & VBNewLine)
ELSE
set logFile = fso.CreateTextFile(logFilePath)
output = output & (FormatDateTime(Now()) + " Create log file." & VBNewLine)
END IF
output = output & (FormatDateTime(Now()) + " Begin Performance Log data." & VBNewLine)
output = output & ( "(Process) (Percent Processor Time) (Working Set(bytes)) (Page Faults Per Second) (PrivateBytes) (PageFileBytes)" & VBNewLine)
WHILE (True)
On Error Resume NEXT
IF Err = 0 THEN
strComputer = "."
Set objRefresher = CreateObject("WbemScripting.SWbemRefresher")
Set objServicesCimv2 = GetObject("winmgmts:\\" _
& strComputer & "\root\cimv2")
Set objRefreshableItem = _
objRefresher.AddEnum(objServicesCimv2 , _
"Win32_PerfFormattedData_PerfProc_Process")
objRefresher.Refresh
' Loop through the processes three times to locate
' and display all the process currently using
' more than 1 % of the process time. Refresh on each pass.
FOR i = 1 TO 3
objRefresher.Refresh
FOR Each Process in objRefreshableItem.ObjectSet
IF Process.PercentProcessorTime > 1 THEN
output = output & (FormatDateTime(Now()) & "," & i ) & _
("," & Process.Name & _
+"," & Process.PercentProcessorTime & "%") & _
("," & Process.WorkingSet) & ("," & Process.PageFaultsPerSec) & _
"," & Process.PrivateBytes & "," & Process.PageFileBytes & VBNewLine
END IF
NEXT
NEXT
ELSE
logFile.WriteLine(FormatDateTime(Now()) + Err.Description)
END IF
logFile.Write(output)
output = Empty
set objRefresher = Nothing
set objServicesCimv2 = Nothing
set objRefreshableItem = Nothing
set objFolder = Nothing
WScript.Sleep(10000)
Wend
I think the main problem with your script is that you initialize WMI objects inside the loop, that is, on every iteration of the loop, even though these objects are always the same:
strComputer = "."
Set objRefresher = CreateObject("WbemScripting.SWbemRefresher")
Set objServicesCimv2 = GetObject("winmgmts:\\" _
& strComputer & "\root\cimv2")
Set objRefreshableItem = _
objRefresher.AddEnum(objServicesCimv2 , _
"Win32_PerfFormattedData_PerfProc_Process")
You need to move this code out of the loop, e.g., at the beginning of the script.
Other tips and suggestions:
Use Option Explicit and explicitly declare all variables used in your script. Declared variables are slightly faster than undeclared ones.
Use FileSystemObject.BuildPath to combine multiple parts of the path. The useful thing about this method is that it inserts the necessary path separators for you.
logFileDirectory = "C:\POSrewrite\data\logs"
filePath = "SCOPerformance-" & Day(Now) & Month(Now) & Year(Now) & ".log"
logFilePath = fso.BuildPath(logFileDirectory, filePath)
The objFolder variable isn't used in your script, so there's no need to create it. Also, you can make the FolderExists check more readable by rewriting it as follows:
If Not fso.FolderExists(logFileDirectory) Then
fso.CreateFolder logFileDirectory
End If
Move repeated code into subroutines and functions for easier maintenance:
Function DateTime
DateTime = FormatDateTime(Now)
End Function
...
output = output & DateTime & " Open log file." & vbNewLine
Usually you don't need parentheses when concatenating strings:
output = output & DateTime & "," & i & _
"," & Process.Name & _
"," & Process.PercentProcessorTime & "%" & _
"," & Process.WorkingSet & "," & Process.PageFaultsPerSec & _
"," & Process.PrivateBytes & "," & Process.PageFileBytes & vbNewLine
In this article, Eric Lippert (Literally worked on designing and building VBScript at Microsoft) indicates that the order in which you dispose of things may be important. Maybe you are running into one of these bugs?
I'll let you read the rest...
When Are You Required To Set Objects To Nothing?
I would recommend against running the script in a permanent loop within the script unless you actually need such a tight loop. I would suggest a single iteration within in the script, called from Scheduled tasks.
I have run into the exact same issue, using it for a procmon-style attempt to capture a rogue process that appears to be respawning.
Narrowing it all down, it appears to be the objRefresher.Refresh and there simply appears to be no way around it
What I did to overcome this was use a for...next to run it 100 times, then immediately afterwards run the following, which would simply respawn the script and shutdown:
CreateObject("Wscript.Shell").Run """" & WScript.ScriptFullName & """", 0, False
So I would watch the memory crawl from 5Mb to 40Mb, then drop back down to 5Mb