On Error works in first and doesn't work in second instance. Bug? - vba

I have a very strange problem here. Here's the code:
reqLang = "ENG"
Select Case reqLang
Case "CRO", "ENG"
'first loop -------------------------------------
On Error GoTo reqLangVisible
i = 1
'Loop until ccCROENG's are all hidden and then go to reqLangVisible.
Do
ActiveDocument.SelectContentControlsByTag("ccCROENG")(i) _
.Range.Font.Hidden = True 'hides all CCs
i = i + 1
Loop
reqLangVisible:
'second loop -------------------------------------
On Error GoTo langOut
i = 1
'Loop until ccreqLang's are all visible and then go to langOut.
Do
ActiveDocument.SelectContentControlsByTitle("cc" & reqLang)(i) _
.Range.Font.Hidden = False 'activates reqLang CCs
i = i + 1
Loop ' CAN'T GET OUT -----------------------------------
Case "CROENG"
i = 1
'Loop until ccCROENG's are all visible and then go to langOut.
Do
On Error GoTo langOut
ActiveDocument.SelectContentControlsByTag("ccCROENG")(i) _
.Range.Font.Hidden = False 'Shows all CCs
i = i + 1
Loop
End Select
langOut:
MsgBox "Success!" '------- yeah, not really.
Stop
I hope it's clear enough what it's trying to do (at least programming-wise). I have multiple ContentControls(CCs) with same titles and tags. The problem I end up with is marked with CAN'T GET OUT, because, you guessed it - I can't get of this second loop! I end up with the Out of range error because it runs out of CCs.
What's even weirder is that it actually did get out of the first loop which has the exact same On Error statement, thought pointing to a different section.
Is it me, or did I just - however unlikely - run onto a bug in VBA?
In any case, is there a solution or at least a workaround?

Typically you only use error handling for dealing with unexpected or unpredictable situations, such as not being able to access a drive, or finding you have no network access.
Error handling is not intended as a substitute for reasonable checks which could otherwise be done. i.e. collections have a Count property which you can use when looping over their items, so avoiding any error caused by trying to access Item(n+1) when there are only n items (and here you know n from Count). Alternatively, use a For Each loop.
Here's some sample code demonstrating use of two methods for looping over your controls:
Sub Tester()
Dim cc1 As ContentControls, cc2 As ContentControls
Dim c, i As Long
With ActiveDocument
Set cc1 = .SelectContentControlsByTag("tbTag")
Set cc2 = .SelectContentControlsByTitle("tbTitle")
End With
Debug.Print "cc1 has " & cc1.Count
Debug.Print "cc2 has " & cc2.Count
'use the Count property
For i = 1 To cc1.Count
Set c = cc1(i)
c.Range.Font.Hidden = True
Next i
'use a For Each loop
For Each c In cc2
c.Range.Font.Hidden = False
Next c
End Sub
This is the type of scenario for which this type of flow control is designed.
Applied to your original code:
Sub Tester2()
Dim reqLang, cc As ContentControls, c
reqLang = "ENG"
Select Case reqLang
Case "CRO", "ENG"
Set cc = ActiveDocument.SelectContentControlsByTag("ccCROENG")
SetTextHidden cc, True
Set cc = ActiveDocument.SelectContentControlsByTitle("cc" & reqLang)
SetTextHidden cc, False
Case "CROENG"
Set cc = ActiveDocument.SelectContentControlsByTag("ccCROENG")
SetTextHidden cc, False
End Select
MsgBox "Success!" '-- yeah really
End Sub
Sub SetTextHidden(cc As ContentControls, MakeHidden As Boolean)
Dim c
For Each c In cc
c.Range.Font.Hidden = MakeHidden
Next c
End Sub

So if you've read my comment, and to formally answer your question, it is not a bug.
You just need to use Error Handling Routines correctly.
What you're trying to do is somewhat like below. HTH.
Select Case reqlang
Case "CRO", "ENG"
On Error Resume Next '~~> ignores the error when encountered
'~~> Your loop which possibly creates the error goes here
On Error Goto 0 '~~> resets the actively triggered error handling
Case "CROENG"
On Error Resume Next '~~> ignores the error when encountered
'~~> Your loop which possibly creates the error goes here
On Error Goto 0 '~~> resets the actively triggered error handling
End Select
MsgBox "Success"
But as the link suggest, you need to handle errors and not simply disregard them. Try cheking on the actual error and find a way to correct it or avoid it.
You'll be surprise that you won't even be needing the Error Handling Routine.

Related

Resume to a label not working as expected

I am having an issue using Resume and although I have found another solution by using an On Error GoTo, I am still confused as to why the code below doesn't work. The initial error occurs because the sheet name "Sheet_1" is already taken. This means that, in the watch window, err.number has a value of 1004 just before the Resume NameAgain is executed. Rather than clear the error and jump back up to the label, an error 20 occurs(resume without error), and the code moves to the End If line.
Given that there is an active error 1004, I can't understand why it acts as though there isn't an error. I have searched the site for Error 20 issues but nothing really resolved this for me or made me understand the logic behind it. Any help is much appreciated.
Sub ErrorTest()
Dim i as integer:i=1
NameAgain: On Error Resume Next
Worksheets("Main").Name = "Sheet_" & i
If Err.Number = 1004 Then
i = i + 1
Resume NameAgain
End If
End Sub
Update after paxdiablo comment:
The above was a poor attempt at trying to replicate but simplify a problem I was having. The section of code I am working with is below:
Activate CheckBook to use ActiveWindow
CheckBook.Activate
Set DestSheet = CheckBook.Worksheets.Add(After:=CheckBook.Sheets(1))
On Error Resume Next
v = 1
NameAgain: DestSheet.Name = ExpBookName & "_" & v
If Err.Number = 1004 Then
v = v + 1
Resume NameAgain
End If
On Error GoTo 0
ActiveWindow.DisplayGridlines = False
Set DestCell = DestSheet.Range("A2")
So the solution is to move the On Error Resume Next to the label line and use GoTo in place of Resume.
The resume statement is a means to, from within an error handler, go back to some point in your main (non-error-handling) code and resume execution.
In this case, you've explicitly stated you want to automatically resume next in the event of an error.
This is functionally equivalent to (VB-like pseudo-code):
line:
on error goto handler
cause error
resume line ' not in an error handler at this point '
handler:
resume next
So you're not technically in an error handler at the point where you try to resume to the label.
The right statement for what you're trying to do would be a simple goto rather than resume.
A more correct solution is to write code that does not deliberately generate errors or which does not use Goto.
Public Function GetNextSheetName(ByVal ipWb As Excel.Workbook, ByVal ipStemName As String) As String
Dim mySheet As Variant
Dim mySD As Scripting.Dictionary
Set mySD = New Scripting.Dictionary
For Each mySheet In ipWb.Sheets
' mySd.Count is a dummy entry to satisfy
' the Key and Item requirements for .Add.
' we are only interested in the Keys
' for use with the .Exists method later
mySD.Add mySheet.Name, mySD.Count
Next
Do
DoEvents
Dim myIndex As Long
myIndex = myIndex + 1
Dim myNextSheetName As String
myNextSheetName = ipStemName + "_" & CStr(myIndex)
Loop While mySD.Exists(myNextSheetName)
GetNextSheetName = myNextSheetName
End Function
Which now allows
Set DestSheet = checkbook.Worksheets.Add(After:=checkbook.Sheets(1))
DestSheet.Name = GetNextSheetName(checkbook, ExpBookName)
ActiveWindow.DisplayGridlines = False
Set DestCell = DestSheet.Range("A2")

Excel 2016 VBA - Compare 2 PivotTables fields for matching values

Hi please can someone help, Excel 2016 VBA PivotTable objects. I rarely develop in Excel VBA.
Overall goal:
Compare a single column [P_ID] value list from PivotTable2 against PivotTable1 if they exist or not to enable filtering on those valid values in PivotTable1.
I have some Excel 2016 VBA code which I have adapted from a previous answer from a different internet source.
Logic is: gather data from PivotTable2 from the ComparisonTable dataset (in PowerPivot model), field [P_ID] list of values. Generate a test line as input into function to test for existence of field and value in PivotTable1 against the Mastertable dataset, if true add the line as valid if not skip the line.
Finally filter PivotTable1 with the VALID P_ID values.
It works to a point until it gets to the bFieldItemExists function which generates an error:
Run-time error '1004'
Unable to get the PivotItems property of the PivotField class
Can someone please correct the way of this not working?
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
Dim MyArray As Variant, _
ar As Variant, _
x As String, _
y As String, _
str As Variant
MyArray = ActiveSheet.PivotTables("PivotTable2").PivotFields("[ComparisonTable].[P_ID].[P_ID]").DataRange
For Each ar In MyArray
x = "[MasterTable].[P_ID].&[" & ar & "]"
If ar <> "" And bFieldItemExists(x) = True Then
If str = "" Then
str = "[MasterTable].[P_ID].&[" & ar & "]"
Else
str = str & "," & "[MasterTable].[P_ID].&[" & ar & "]"
End If
End If
Next ar
Dim str2() As String
str2 = Split(str, ",")
Application.EnableEvents = False
Application.ScreenUpdating = False
ActiveSheet.PivotTables("PivotTable1").PivotFields("[MasterTable].[P_ID].[P_ID]").VisibleItemsList = Array(str2)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function bFieldItemExists(strName As String) As Boolean
Dim strTemp As Variant
' This line does not work!?
strTemp = ActiveSheet.PivotTables("PivotTable1").PivotFields("[MasterTable].[P_ID].[P_ID]").PivotItems(strName)
If Err = 0 Then bFieldItemExists = True Else bFieldItemExists = False
End Function
The 1004 error occurred due to the use of square brackets [ ]. Remove those.
You also need to use the key word Set when you set an object equal to something. For example Set MyArray = ActiveSheet.PivotTables("PivotTable2").PivotFields("ComparisonTable.P_ID.[P_ID").DataRange.
If you don't use Set you will get a VBA run-time error dialog that says Run-time error '91': Object variable or With block variable not set
I cannot guarantee that my edits will completely solve your problem since I don't have your data set and cannot fully test your code. You will need to use the Debug mode in the VBA editor and single step through the code. To this set a breakpoint on the Set mDataRange = Active.... To set a breakpoint go to the Debug menu and choose the "Toggle Breakpoint" sub-menu item or you can press F9 to set the breakpoint.
Now when you make a change to the Pivot table, the Worksheet_PivotTableUpdate event will fire and the code will top execution at that point.
After the code stops executing due to the breakpoint, you can press the F8 key to single step through your code. If you want to resume execution to the next breakpoint you can press F5. Also when you get the VBA error dialog box, you can hit Debug and then use the F8 key to single step or use the debug windows to see what your variables and objects contain. I'm sure there are some good youtube videos on VBA debugging.
As you single step through the code, you can observe what each variable/object contains using the Immediate window, the Watches window and the Locals window. To open these windows, go to the menu item View and click on each of these sub-menu items.
Here's how you need to edit your code before debugging.
Option Explicit
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
'Better practice is to not use the underscore character to
'continue a Dim declaration line
Dim mDataRange As Range
Dim ar As Range
Dim x As String
Dim y As String
Dim str As Variant
'Use Set to assign the object mDataRange a reference to the the right
'hand side of the equation. Remove the square brackets
'MyArray = ActiveSheet.PivotTables("PivotTable2").PivotFields("[ComparisonTable].[P_ID].[P_ID]").DataRange
Set mDataRange = ActiveSheet.PivotTables("PivotTable2").PivotFields("ComparisonTable.P_ID.P_ID").DataRange
For Each ar In mDataRange
'You need to specify what proprerty from ar you
'want to assign to x. Assuming the value stored in
'ar.Value2 is a string, this should work.
'We use value2 because it is the unformmated value
'and is slightly quicker to access than the Text or Value
'properties
'x = "[MasterTable].[P_ID].&[" & ar & "]"
x = "MasterTable.P_ID." & ar.Value2
'Once again specify the Value2 property as containing
'what value you want to test
If ar.Value2 <> "" And bFieldItemExists(x) = True Then
If str = "" Then
'Remove the square brackets and use the specific property
'str = "[MasterTable].[P_ID].&[" & ar & "]"
str = "MasterTable.P_ID." & ar.Value2
Else
'Remove the square brackets and use the specific property
'str = str & "," & "[MasterTable].[P_ID].&[" & ar & "]"
str = str & "," & "MasterTable.P_ID." & ar.Value2
End If
End If
Next ar
Dim str2() As String
str2 = Split(str, ",")
Application.EnableEvents = False
Application.ScreenUpdating = False
'Remove square brackets
'ActiveSheet.PivotTables("PivotTable1").PivotFields("[MasterTable].[P_ID].[P_ID]").VisibleItemsList = Array(str2)
ActiveSheet.PivotTables("PivotTable1").PivotFields("MasterTable.P_ID.P_ID").VisibleItemsList = Array(str2)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function bFieldItemExists(strName As String) As Boolean
'Declare a PivotItem to accept the return value
Dim pvItem As PivotItem
'Since you want to trap for an error, you'll need to let the VBA runtime know
'The following code is a pseudo Try/Catch. This tells the VBA runtime to skip
'the fact an error occured and continue on to the next statement.
'Your next statement should deal with the error condition
On Error Resume Next
'Use Set whenever assigning an object it's "value" or reference in reality
Set pvItem = ActiveSheet.PivotTables("PivotTable1").PivotFields("MasterTable.P_ID.P_ID").PivotItems(strName)
'Assuming that an error gets thrown when strName is not found in the pivot
'Err is the error object. You should access the property you wish to test
If Err.Number = 0 Then
bFieldItemExists = True
Else
bFieldItemExists = False
End If
'Return to normal error functioning
On Error GoTo 0
End Function
Finally, I realize that some of this should be in the comments section, but there was too much I needed to explain to help Learner74. BUT most importantly, I hope I helped him. I have used so many suggestions, recommendations and explanations from the VBA Stack Overflow exchange through the years, I just want to pay it back by paying it forward.
Additional USEFUL Links:
Chip Pearson is the go to site and person for all things VBA
Paul Kelly's Excel Macro Mastery is another go to site for Excel and VBA questions.
Microsoft Excel Object Model which is sometimes useful, but needs improvement. Too many of the objects lack examples, but can at least point you in the right direction.

Error Handling within a Loop for PivotTable object sorting

I've been trying to sort PivotTable objects in VBA using a function I've attempted:
Public Function PTSort(PTName As String, PTFieldName as String, SortArray As Variant)
Dim m as Integer: m = 1 'Row counter
Dim i as Long 'Dummy Variable for cycling
With ActiveSheet.PivotTables(PTName).PivotFields(PTFieldName)
.Parent.ManualUpdate = True
For i = LBound(SortArray) To UBound(SortArray)
With .PivotItems(SortArray(m - 1)) 'For in-code array
.Position = m
End With
m = m + 1
Next i
.Parent.ManualUpdate = False
End With
End Function
Whilst this works well with a known set of elements within SortArray, I have a master list to follow whilst sorting (so as to standardise a few orders accross several PivotTables), in which the PivotTable need not necessarily contain all said PivotItems. I have hence improved it to the following:
Sub PTSort(PTName As String, PTFieldName as String, SortArray As Variant)
Dim m as Integer: m = 1
Dim i as Long
Dim k As Integer: k = 1 'To cycle the position independently from the array in the event of disjoint.
With ActiveSheet.PivotTables(PTName).PivotFields(PTFieldName)
.Parent.ManualUpdate = True
For i = LBound(SortArray) To UBound(SortArray)
On Error GoTo ERRHANDLER:
With .PivotItems(SortArray(k)) 'After parsing from range of cells into VariantArray, then does one not require the "-1"
.Position = m
End With
m = m + 1
ExitHandler:
k = k + 1
Next i
.Parent.ManualUpdate = False
End With
GoTo ENDEND:
ERRHANDLER:
GoTo EXITHANDLER:
ENDEND:
End Sub
The OnError GoTo seems to only work once though, irregardless of how high up placed it?
Help would be greatly appreciated. Thanks in advance!
This is from MSDN on Visual Studio but I think it applies to VBA in the same way.
An "enabled" error handler is one that is turned on by an On Error statement. An "active" error handler is an enabled handler that is in the process of handling an error.
If an error occurs while an error handler is active (between the occurrence of the error and a Resume, Exit Sub, Exit Function, or Exit Property statement), the current procedure's error handler cannot handle the error. Control returns to the calling procedure
So after your code first gets to On Error GoTo ERRHANDLER, ERRHANDLER is enabled. Then when an error occurs ERRHANDLER is activated and handles the error. When you GoTo EXITHANDLER it stays active and still handles the error. The On Error GoTo ERRHANDLER has no effect at this point.
To re-enable the ERRHANDLER you need to use Resume EXITHANDLER instead of GoTo EXITHANDLER.
Edit on the Resume statement. There are three ways to use Resume: Resume, Resume Next and Resume label
Resume without an argument causes the code to resume at the line that caused the error. This obviously has to be used very careful as you must be absolutely certain that you fixed the problem or you'll end up in an infinite loop.
Resume Next causes the code to resume at the line after the line that caused the error.
Resume Label is almost the same as GoTo Label but with this you exit the error handler and resume normal code execution. The error handler is re-enabled.

Excel VBA UserForm 'OK'

Does anyone know how to make a userform function in the same way as the Message Box 'ok' button? I'll explain.
I'm detecting errors in a column in a spreadsheet. When an error is found, a message box pops up as follows:
MsgBox "Please enter valid data"
When I select "OK" it goes to the next error in the column. This is great, except of course a message box is modal, which freezes the application. I want the user to be able to edit the data and then move to the next error. So, I designed a userform, which can be non-modal. Great, except I want the macro to advance to the next error. It will do that IF the user corrects the error. If they do not, it just stays at that error cell.
I know WHY this happens. My userform 'Next' button just calls the macro which finds the first error. But what I want to know is if there is a way around this.
Error checking starts at row 19 because that is where user input data starts.
I'm including a link to the spreadsheet here. Module 1 'NextValidationError' works great and proceeds to the next error. Module 14 just hangs at the error until it is resolved. I'd like it to be able to skip.
https://www.dropbox.com/s/yqko5kj19pnauc9/Transparency%20Data%20Input%20Sheet%20for%20Indirect%20Spend%20V7%2009212016%20v2%200.xlsm?dl=0
Can anyone give me advice on how to make module 14 proceed as module 1?
Something like this:
Dim r_start As Long
Sub CheckNames()
Dim r As Long
'Dim emptyRow As Boolean
If r_start = 0 Then r_start = 19
With ActiveSheet
For r = r_start To 5000
'Checks entire row for data. User may skip rows when entering data.
If WorksheetFunction.CountA(.Range(.Cells(r, 1), .Cells(r, 33))) > 0 Then
If ((.Cells(r, 2) = "") <> (.Cells(r, 3) = "")) Or _
((.Cells(r, 2) = "") = (.Cells(r, 4) = "")) Then
MsgBox "Please fill in First and Last Name or HCO in Row " & r & "."
End If
End If
Next
End With
End Sub
Unless I'm mis-reading your code you can combine your two checks with Or.
You will need some method to reset r_start when the user is done checking (if the form stays open after that).
EDIT: here's a very basic example.
UserForm1 has two buttons - "Next" and "Close"
Code for "next" is just:
Private Sub CommandButton1_Click()
ShowErrors
End Sub
In a regular module:
Dim r_start As Long
'this kicks off the checking process
Sub StartChecking()
r_start = 0
UserForm1.Show vbModeless
ShowErrors
End Sub
'a simple example validation...
Sub ShowErrors()
Dim c As Range, r As Long
If r_start = 0 Then r_start = 9
For r = r_start To 200
With ActiveSheet.Rows(r)
If Not IsNumeric(.Cells(1).Value) Then
UserForm1.lblMsg.Caption = "Cell " & .Cells(1).Address() & " is not numeric!"
r_start = r + 1
Exit Sub
End If
End With
Next r
r_start = 0
UserForm1.lblMsg.Caption = "No more errors"
End Sub

VBA MsgBox causes an erro

In my VBA project I have the occasional MsgBox pop up to notify the user something has 'Completed' or 'Updated' after a subroutine has run.
It seems to run okay without the MsgBox, but inserting one seems to give me an error.
Not sure if it's necessary to display the entire code here as it's quite big but at the end of a subroutine I simply want ...
MsgBox ("Completed")
which is followed by the End Sub
However when I run this and then click on OK on the Msgbox, I get a runtime error which on clicking DeBug, it highlights the End Sub.
Is there any reason why having this would throw up such an error?
Am I missing something from it?
Many thanks
Some of the code here
'Add unique data to new location
For i = 1 To UnqArray1.Count
rCell(i, 1) = UnqArray1(i)
Next
'Move Split Array into a new array
Set rTable2 = rCell
rng2() = rTable2.Value
'Filter into unique items
On Error Resume Next
For Each b In rng2
UnqArray2.Add b, b
Next
'Clear location
rCell.Clear
'Add new array to location
For i = 1 To UnqArray2.Count
rCell(i, 1) = UnqArray2(i)
Next
'Find the end of the category list
lastrow = Worksheets("CatMatch").Range("Q100000").End(xlUp).Row
'Sort alphabetically
Worksheets("CatMatch").Range("Q1:Q" & lastrow).Sort key1:=Range("Q1"), order1:=xlAscending, Header:=xlNo
'Copy it to CatMatch
Worksheets("CatMatch").Range("Q1:Q" & lastrow).Copy Destination:=Worksheets("CatMatch").Range("B15")
MsgBox "Completed"
End Sub
I can't reproduce your error, but you are almost certainly incorrect that it runs okay without the MsgBox. The problem is that the problem with your code is being hidden by On Error Resume Next in the fragment:
'Filter into unique items
On Error Resume Next
For Each b In rng2
UnqArray2.Add b, b
Next
Two comments:
1) Why not use the RemoveDuplicates method if that is what you are trying to do?
2) Your code is using the fact that a collection throws an error if you try to add a duplicate key. This is a valid use of On Error Resume Next -- but only if you turn it off when you are done adding keys to the collection. Something like:
On Error Resume Next
For Each b In rng2
UnqArray2.Add b, b
Next
On Error GoTo 0
A good habit to get into is to consider On Error Resume Next and On Error GoTo 0 as defining a block of code, perhaps even indenting the code inside the block as I did above. An even better habit is to not assume that only 1 type of error can happen. The above code is expecting that error 457 might arise (this is the error number corresponding to trying to add a duplicate key -- you need to search documentation to find it, or just run your code without the error handling and see how it crashes). Anything else indicates some other problem. To be maximally safe you can do something like:
On Error Resume Next
For Each b In rng2
UnqArray2.Add b, b
If Err.Number > 0 And Err.Number <> 457 Then
MsgBox "Unhandled error: " & Err.Number
Exit Sub
End If
Next
On Error GoTo 0
Doing this won't solve your problem, but should make your actual problem more apparent.