I'm trying to build a dynamic progress bar in Excel, and the way I'm currently doing this is by hard-coding a number of steps into my script as the "total number of steps"... the Application.StatusBar code gets updated with a counter that is divided by this total.
What I'd like to do is to have "TotalSteps" pre-populate with 3 (using the example below) by searching ahead through the code to identify the number of times "Call fnProgress" appears in the subroutine.
Public Sub Example()
TotalSteps = 3 'Enter a value here equal to the number of times "Call fnProgress" appears below
Call ABC
Call fnProgress
Call 123
Call fnProgress
Call DoReMi
Call fnProgress
End Sub
I don't get the impression this is possible in VBA, but I figured someone here would know how to do it if it was! Or perhaps someone could offer a better solution to my simple progress bar... Being able to search ahead in the actual code is also an interesting problem, to me, and I'd imagine it's got further application beyond my status bar.
Thanks so much!
-Julia :)
It is possible, but it's not pretty.
I would consider the solution below bad practice in most cases. Anyway - here it goes:
Sub Test()
Dim StepCount As Integer
Dim TotalSteps As Integer
Steps = Array("Abc", "Def", "Ghi")
TotalSteps = UBound(Steps) + 1
For Each Step In Steps
StepCount = StepCount + 1
ActiveSheet.Evaluate Step & "()+0" '+0 is workaround to handle a bug in VBA. Without it, the method is called twice
Progress StepCount, TotalSteps
Next
End Sub
Sub Progress(StepCount As Integer, TotalSteps As Integer)
Debug.Print StepCount & "(" & TotalSteps & ")"
End Sub
Sub Abc()
Debug.Print "Abc"
End Sub
Sub Def()
Debug.Print "def"
End Sub
Sub Ghi()
Debug.Print "ghi"
End Sub
The base for this is the Evaluate function, that allows you to evaluate expressions in strings. The Test method calls the methods in the Steps array, using Evaluate.
Here's a different approach. Not a good way to write code, but again, there are situations where it is warranted.
Start by adding a reference to Microsoft Visual Basic for Applications Extensibility, then add this code:
Sub Test()
Dim CodeMod As VBIDE.CodeModule
Set CodeMod = ActiveWorkbook.VBProject.VBComponents("Module1").CodeModule
Debug.Print CountOccurrences("Call fnProgress", CodeMod.Lines(1, CodeMod.CountOfLines)) - 1 'Remove 1 to ignore this line
End Sub
Function CountOccurrences(SoughtString As String, InString As String) As Long
CountOccurrences = (Len(InString) - (Len(Replace(InString, SoughtString, "")))) / Len(SoughtString)
End Function
The module name is hardcoded. It reads the code, counts the number of occurences of Call fnProgress and subtracts one (so that the count it self isn't counted). Adjust as needed.
Related
First time postings and I'm far from a VBA expert, but I've managed to stumble most of the way to my desired outcome thanks to boards like this one. I'm hoping to automate one last step and am looking for some assistance.
Background:
I run project reports for our Project Managers every Monday morning. The report template queries several tables in our database and populates all of the appropriate fields. It then creates a copy of itself, saves the formulas as values and saves the report using a naming mechanism capturing data from various fields in the report. All of this works great!
The Issue:
At any given time, I have 80-100 active projects. As it stands, I copy the list of projects to a table on the "Parameters" tab. Then, using data validation, I created a dropdown list on the "Report" tab. I then manually go 1 by 1 through the list to generate the report. Each time I change project number in cell B1, the data refreshes and runs the report for the project. I'm using this code to accomplish that:
Private Sub Worksheet_Change(ByVal Target As Range)
'MsgBox Target.Address
If Not Application.Intersect(Range("b1"), Range(Target.Address)) Is Nothing Then
Call AA_RunAll
End If
End Sub
What I'd like to do is create a macro that will run through each one of the projects on my list and run the report. I'm assuming it's a loop function, but I can't seem to get it to work as I want.
One other consideration to note: it takes 3-5 minutes per report to refresh all the data, generate the report and save it. I'd like to set this to run before I leave at night and have it done in the morning.
Thanks in advance.
Aaron
I think this may be what you are looking for.
Dim DataValidationRange As Range
Dim Str As String
Str = Replace(Range("B1").Validation.Formula1, "=", "")
Set DataValidationRange = Range(Str)
Dim i
For Each i In DataValidationRange
Range("B1").Value = i
Call AA_RunAll
Next
Also if you need to wait for the data to update before calling AA_RunAll, you could use this:
Public Function MyTimer(MyDelay As Double)
Dim MyTimerTimer As Double
MyTimerTimer = Timer
MyDelay = MyDelay + Timer
Do While MyTimerTimer <= MyDelay
MyTimerTimer = Timer
DoEvents
Loop
End Function
Private Sub GoThrough_Dropdown()
Dim DataValidationRange As Range
Dim Str As String
Str = Replace(Range("B1").Validation.Formula1, "=", "")
Set DataValidationRange = Range(Str)
Dim i
For Each i In DataValidationRange
Range("B1").Value = i
WaitForDataToUpdate
Call AA_RunAll
Next
End Sub
Private Sub WaitForDataToUpdate()
Dim RangeToWaitFor As Range
Set RangeToWaitFor = Range("H5")
Dim Str As String
Str = RangeToWaitFor.Value
Do While Str = RangeToWaitFor.Value
MyTimer 1
Loop
End Sub
In my spreadsheet, I have a UserForm that is supposed to be open at all times.
Once in a while, my code will contain an "End" where I exit the code based on some if statement.
The problem is that this closes the UserForm, is there a way to prevent this from happening?
EDIT:
Sub Test1()
'Random code
Call Test2(Variable)
'Random code
End Sub
Sub Test2(ByVal Variable as Double)
If Variable = 0 then
'Random code
End If
If Variable = 1 then
Call Test3
End 'Original placement of End
End If
End Sub
Sub Test3()
'Random code
End Sub
This is a rough example of how the code is build (its rather long at this point). So depending on the "variable" different things happen in Test2. But if the Variable is 1, then the "random code" back in Test1 can't be executed thus, so I have to stop the code. I tried replace "End" with "Exit Sub" this only stops the code in Test2 from running, is it will give me an error when it goes back to Test1.
EDIT2:
Test1() is actually four different subs (at this point, more will be added) that all call Test2(). That is why I choose to split it up into so many subs and call them from within the subs.
No, not if you insist on using End. This will essentially have the same effect as clicking the "Stop" button in the developer window. You should (most likely) not be using End. I cannot tell you what you should be using, since I do not know what you are trying to achieve.
Update:
Based on your code, I don't see any reason for Test3() to be nested within Test2(), since it runs either the random code or Test3() (never both). Is there anything preventing you from splitting all the different cases into different subs, and then doing the If statement in the main sub?
Sub Main()
If Variable = 0 Then
'Random code from before Test2()
'Random code from Test2()
'Random code from after Test2()
ElseIf Variable = 1 Then
Call Test3()
Else
MsgBox "Variable must be 0 or 1!"
End Sub
You somehow need to tell Test1 that it needs to stop. One approach to this problem is to change your subs to functions and return a value indicating status. Something like this would work:
Function Test1() As Integer
Dim i As Integer
'Random code
i = Test2(Variable)
If i = 1 Then Exit Function
'Random code
End Function
Function Test2(ByVal Variable As Double) As Integer
Test2 = 0
If Variable = 0 Then
'Random code
End If
If Variable = 1 Then
Call Test3
Test2 = 1
Exit Function
End If
End Function
Function Test3() As Integer
'Random code
End Function
End closes anything and kills all the variables and objects that you have.
This is probably the worst way to end any sub and most probably you do not need it.
What's the deference between "end" and "exit sub" in VBA?
https://msdn.microsoft.com/VBA/Language-Reference-VBA/articles/end-statement
Lets say I have the following:
Public Sub Information()
'TEST
End Sub
Is there a way to get "TEST" as a result?
Somehow through VBA?
E.g. - In PHP there is a good way to take the comments. Any ideas here?
Edit:
There should be a way, because tools like MZ-Tools are able to provide the comments when they generate the documentation.
You need to parse the code yourself, using the VBA Extensibility library (aka "VBIDE API"). Add a reference to the Microsoft Visual Basic for Applications Extentibility 5.3 type library, and then you can access types such as CodePane and VBComponent:
Sub FindComments()
Dim component As VBComponent
For Each component In Application.VBE.ActiveVBProject.VBComponents
Dim contents As String
contents = component.CodeModule.Lines(1, component.CodeModule.CountOfLines)
'"contents" now contains a string with the entire module's code.
Debug.Print ParseComments(contents) 'todo
Next
End Sub
Once you have a module's contents, you need to implement logic to find comments... and that can be tricky - here's some sample code to play with:
Sub Test()
Dim foo 'this is comment 1
'this _
is _
comment 2
Debug.Print "This 'is not a comment'!"
'..and here's comment 3
REM oh and guess what, a REM instruction is also a comment!
Debug.Print foo : REM can show up at the end of a line, given an instruction separator
End Sub
So you need to iterate the lines, track whether the comment is continuing on the next line / continued from the previous line, skip string literals, etc.
Have fun!
After some tests, I got to this solution:
simply pass the name of the code-module to the function and it will print all comment lines. Inline comments won't work(you have to change the condition)
Function findComments(moduleName As String)
Dim varLines() As String
Dim tmp As Variant
With ThisWorkbook.VBProject.VBComponents(moduleName).CodeModule
'split the lines of code into string array
varLines = Split(.lines(1, .CountOfLines), vbCrLf)
End With
'loop through lines in code
For Each tmp In varLines
'if line starts with '
If Trim(tmp) Like "'*" Then
'print comment line
Debug.Print Trim(tmp)
End If
Next tmp
End Function
You can use Microsoft Visual Basic for Applications Extensibility to examine code at runtime:
'Requires reference to Microsoft Visual Basic for Applications Extensibility
'and trusted access to VBA project object model.
Public Sub Information()
'TEST
End Sub
Public Sub Example()
Dim module As CodeModule
Set module = Application.VBE.ActiveVBProject.VBComponents(Me.CodeName).CodeModule
Dim code As String
code = module.lines(module.ProcStartLine("Information", vbext_pk_Proc), _
module.ProcCountLines("Information", vbext_pk_Proc))
Dim lines() As String
lines = Split(code, vbCrLf)
Dim line As Variant
For Each line In lines
If Left$(Trim$(line), 1) = "'" Then
Debug.Print "Found comment: " & line
End If
Next
End Sub
Note that the above example assumes that it's running in a Worksheet or Workbook code module (hence Me when locating the CodeModule). The best method for locating the correct module will depend on where you want to locate the procedure.
You could try with reading line by line of code in your module. Here is just idea returning first comment for further improvements:
Sub callIt()
Debug.Print GetComment("Module1")
End Sub
Function GetComment(moduleName As String)
Dim i As Integer
With ThisWorkbook.VBProject.VBComponents(moduleName).CodeModule
For i = 1 To .CountOfLines
If Left(Trim(.Lines(i, 1)), 1) = "'" Then
'here we have comments
'return the first one
GetComment = .Lines(i, 1)
Exit Function
End If
Next i
End With
End Function
Important! in Reference window add one to 'Microsoft Visual Basic for Applications Extensibility'.
I'd like to use the .DeleteLinesfunction in VBA. As I'm not deleting all the lines in the module i need a targeted approach. I assume there is a function like Find("FooBar").LineNumber, however I can't find it here/with google:
https://msdn.microsoft.com/en-us/library/office/gg264546.aspx
Sub Deletings()
With Workbooks("ClassExperiment.xlsm").VBProject.VBComponents("Module2").CodeModule
.DeleteLines(HowDoIGetThisValue, 0)
End With
End Sub
Help appreciated.
If you're removing the entire procedure, you can find its location with the ProcStartLine property and the line count with ProcCountLines.
Dim module As CodeModule
Set module = Workbooks("ClassExperiment.xlsm").VBProject.VBComponents("Module2").CodeModule
Dim start As Long
Dim lines As Long
With module
start = .ProcStartLine("button_Click", vbext_pk_Proc)
lines = .ProcCountLines("button_Click", vbext_pk_Proc)
.DeleteLines start, lines
End With
Warning:
This should be obvious, but I'll throw it out there anyway. Do not use this (or any other method) to alter the module that the code is running from in Debug mode. This is a good way to break your workbook.
Sub test()
Dim vb As VBComponent
Dim i As Integer
Set vb = ThisWorkbook.VBProject.VBComponents("Module2")
For i =vb.CodeModule.CountOfLines to 1 step -1
If InStr(1, vb.CodeModule.Lines(i, 1), "' remove") <> 0 Then
vb.CodeModule.DeleteLines i, 1
End If
Next i
End Sub
I would of also suggested using a condition statement to allow execution of the code line, rather than deleting it, when is it put back? this could cause issues if you wish to automate that bit, as you'll need to know where it came from.
I have absolutely no idea how to create separate subs/functions to shorten the code. I am referring to those subs(something as integer, etc)
Below we have this code that resides in my core module
Set els = IE.Document.getelementsbytagname("a")
For Each el In els
If Trim(el.innertext) = "Documents" Then
colDocLinks.Add el.href
End If
Next el
For Each XML_link In colDocLinks
LoadPage IE, CStr(XML_link)
For Each el In IE.Document.getelementsbytagname("a")
If el.href Like "*[0-9].xml" Then
With Worksheets("CONTROL_ROOM").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
.NumberFormat = "#"
.Value = Ticker
.Offset(0, 1).Value = el.href
End With
Debug.Print el.innertext, el.href
colXMLPaths.Add el.href
End If
Next el
Next XML_link
I really need to shorten my code. How could i create a separate sub or function instead of having this chunk of code into my main module?
Books offer over-simplistic examples and have not been any help to me in real situations like this one. Do i need to make declarations such as Dim els inside the separate Sub or Function? Thank you for your patience in advance.
And most importantly no-matter how much time i look to these examples i cannot figure out which variables i put in here:
(Private) Sub / (Private) Function ( variables ?)
+++Any good examples/links will help.
Create a subroutine anytime you want to be able to call a block of code to do something, without returning any kind of value to the code that called it:
Sub MainCode()
Dim myString as String
...'all your main code
Call OtherSub(myString)
...'all your main code
End Sub
Sub OtherSub(theString as String)
'Do Something with the string theString
End Sub
Create a function when you want to return something:
Sub MainCode()
Dim myString as String, newString as String
...'all your main code
NewString = OtherSub(myString)
...'all your main code
End Sub
Function ManipulateString(theString as String)
'Do Something with the string theString
ManipulateString = theString & ...
End Function
At the end of the function, to return the new value, simply set the function name equal to whatever you are passing back.
Hope that helps.