When the code is applied to a pivot table that has no PageRange property the code fails with the error in the title
I tried to apply a boolean variable to
sh.PivotTables(i).PageRange
but that did not work either
Sub TestPivotPaste2()
Dim wb As Workbook
Dim sh As Worksheet
Set wb = ActiveWorkbook
Set sh = wb.Worksheets(7)
c = sh.PivotTables.Count
If c > 0 Then
For i = 1 To c
If Not sh.PivotTables(i).PageRange.Count = 0 Then
Debug.Print c
Else
GoTo nextpiv
End If
nextpiv:
Next i
Else
MsgBox ("NoPivot")
End If
End Sub
the expected result is to be able to discern the pivot tables where the PageRange property is true or false, but it only works when the range exists.
Try this function
Function pageRangeExists(pt as PivotTable) as Boolean
Dim test as Range
On Error Resume Next
Set test = pt.PageRange
On Error Go To 0
pageRangeExists = Not test Is Nothing
End Function
Since PageRange is a range object, you have to test if the range exists or is valid first, as trying to act against a range that is not there will produce an error.
And with that your for loop can be simplified
For i = 1 To c
If pageRangeExists(sh.PivotTables(i)) Then
Debug.Print c
End If
Next i
The GoTo statement is superfluous as it is logic already embedded in a for loop.
Related
Hello
I have an error 13 on my vlookup all the time ,when I execute vlookup on my sheet it works soon vba doesn't I am looking for help
here is my code , all the columns are Text in my sheet
Sub address_change()
Dim updatesheet As Variant
Dim sbw As String
Dim Param As String
Dim entier As Integer
Dim fname As String
Dim tsk As Task
Dim rg As Variant
Dim ws As Sheets
Dim wb As Excel.Workbook
Dim appXLS As Object
Dim entxls As Object
Dim i As Integer
Set appXLS = CreateObject("Excel.Application")
If appXLS Is Nothing Then
MsgBox ("XLS not installed")
End If
fname = ActiveProject.Path & "\" & Dir(ActiveProject.Path & "\addresses.xlsx")
MsgBox (fname)Set wb = appXLS.Workbooks.Open(fname, False)
Set rg = appXLS.Worksheets("sheet2").Range("A:U")
appXLS.Visible = TrueMsgBox (appXLS.Application.Value)
On Error Resume Next
For Each tsk In ActiveProject.Tasks
Param = tsk.Text2
If tsk.OutlineLevel = 2 Then
updatesheet = appXLS.Application.VLookup(Param, rg, 16, False)
If Err.Number <> 0 Then
tsk.Text13 = "No match 32"
Else
tsk.Text13 = updatesheet
End If
End If
Next tsk
End Sub
There are two ways to use the Excel VLookup (and similar functions like Match) with VBA, and they differ.
Application.VLookup (the version you are using) will return an error value Error 2042 if the search term cannot be found. This is not a runtime error, this is a return value. Error values are a special data type in VBA (they are not strings, the Error 2042 is just the representation of it). To be precise, this error is the #N/A that you see in Excel if a Vlookup fails.
You write the result into variable updatesheet, that is fine as it is declared as Variant, and a variant can hold an error value. However, now you check if an error occurred and as this is not the case, it will try to assign the error value to tsk.Text13 and this gives you a type mismatch error (I assume that tsk.Text13 expects a string).
Instead of checking for a runtime error as you do, you need to check if updatesheet contains an error value, this is done using the IsError-function. In this case, you could also use the Application.IsNA()-function.
The alternative is to use WorksheetFunction.Vlookup, this will throw a runtime error if can't find the search term, and you need to wrap this into Error handling.
Use either the one or the other method:
updatesheet = appXLS.VLookup(Param, rg, 16, False)
If appXLS.IsNA(updatesheet) Then
tsk.text13 = "No match 32"
Else
tsk.text13 = updatesheet
End If
updatesheet = "No match 32"
On Error Resume Next
updatesheet = appXLS.WorksheetFunction.VLookup(Param, rg, 16, False)
On Error GoTo 0
tsk.text13 = updatesheet
For further reading, I recommend https://rubberduckvba.wordpress.com/2021/02/15/worksheetfunction-and-errors/
I am having trouble using variables within the lookup criteria in Index Match. Some background: I use the following code to set a variable's value to the row # of whatever cell contains "Current" within column B:
Dim rowHeaderNum As Integer
rowHeaderNum = 0
On Error Resume Next
rowHeaderNum = Application.Match("Current", ActiveSheet.Range("B:B"), 0)
On Error GoTo 0
Then I use the below to store the column # of the cell within the row 'rowHeaderNum' that contains the value "CurrentActual" to another variable:
Dim currActColNum As Integer
currActColNum = 0
currActColNum = Application.Match("CurrentActual", Rows(rowHeaderNum & ":" & rowHeaderNum), 0)
Below is the Index Match line that I can't get to work:
Dim currActRev As Double
currActRev = Application.Index(Columns(currActColNum), Application.Match("Gross Operating Profit", Columns("N:N"), 0))
currActRev will store a dollar amount. The Match function will always use column N as the lookup array. When I run the Index Match line I get a
type mismatch
error in the debugger.
Using WorksheetFunction …
Application.Match and On Error Resume Next does not work, because Application.Match does not throw exceptions you need to use WorksheetFunction.Match instead.
According to the documentation the WorksheetFunction.Match method it returns a Double so you need to Dim RowHeaderNum As Double.
Dim RowHeaderNum As Double
'RowHeaderNum = 0 'not needed it is always 0 after dim
On Error Resume Next
RowHeaderNum = Application.WorksheetFunction.Match("Current", ActiveSheet.Range("B:B"), False)
On Error GoTo 0
Furthermore you need to check if RowHeaderNum is 0 and stop proceeding otherwise the following code will fail because row 0 does not exist.
If RowHeaderNum = 0 Then
MsgBox "'Current' not found."
Exit Sub
End If
You need to do exactly the same here
Dim CurrActColNum As Double
On Error Resume Next
CurrActColNum = Application.WorksheetFunction.Match("CurrentActual", Rows(RowHeaderNum), False)
On Error GoTo 0
If CurrActColNum = 0 Then
MsgBox "'CurrentActual' not found."
Exit Sub
End If
Finally the WorksheetFunction.Index method returns a Variant not a Double and you need error handling here too.
Dim currActRev As Variant
On Error Resume Next
currActRev = Application.WorksheetFunction.Index(Columns(CurrActColNum), Application.WorksheetFunction.Match("Gross Operating Profit", Columns("N:N"), False))
On Error GoTo 0
Debug.Print currActRev 'print result in immediate window
Using Application …
Note that you can also use the Application.Match and Application.Index (without WorksheetFunction) but then you cannot use On Error … and you have to check for errors using IsError(). Also your variables need to be declared as Variant then because Application.Match can either return a typo Double or a type Error.
Dim RowHeaderNum As Variant
RowHeaderNum = Application.Match("Current", ActiveSheet.Range("B:B"), False)
If IsError(RowHeaderNum) Then
MsgBox "'Current' not found."
Exit Sub
End If
Dim CurrActColNum As Variant
CurrActColNum = Application.Match("CurrentActual", Rows(RowHeaderNum), False)
If IsError(CurrActColNum) Then
MsgBox "'CurrentActual' not found."
Exit Sub
End If
Dim currActRev As Variant, currMatch As Variant
currMatch = Application.Match("Gross Operating Profit", Columns("N:N"), False)
If Not IsError(currMatch) Then
currActRev = Application.Index(Columns(CurrActColNum), currMatch)
End If
Debug.Print currActRev 'print result in immediate window
My code is working fine but it ends up giving me a runtime error "object required.
I am not able to find out what is causing this error. This code is related to deleting graphs that don't have any data in them .
Sub HideEmptyCharts()
Dim wksCharts As Worksheet
Dim objCO As ChartObject
' Set up a variable for the worksheet containing the charts
Set wksCharts = ThisWorkbook.Sheets("Report output")
' Loop through every embedded chart object on the worksheet
For Each objCO In wksCharts.ChartObjects
' Make each one visible
objCO.Visible = True
' If the chart is empty make it not visible
If IsChartEmpty(objCO.Chart) Then objCO.Visible = False
Next objCO
End Sub
Private Function IsChartEmpty(chtAnalyse As Chart) As Boolean
Dim i As Integer
Dim j As Integer
Dim objSeries As Series
' Loop through all series of data within the chart
For i = 1 To chtAnalyse.SeriesCollection.Count
Set objSeries = chtAnalyse.SeriesCollection(i)
' Loop through each value of the series
For j = 1 To UBound(objSeries.Values)
' If we have a non-zero value then the chart is not deemed to be empty
If objSeries.Values(j) <> 0 Then
' Set return value and quit function
IsChartEmpty = False
Exit Function
End If
Next j
Next i
IsChartEmpty = True
End Function
Change the object passed to the function from Chart to full ChartObjectlike this:
Private Sub HideEmptyCharts()
Dim wksCharts As Worksheet
Dim objCO As ChartObject
Set wksCharts= ThisWorkbook.Sheets("Report output")
For Each objCO In wksCharts.ChartObjects
objCO.Visible = True
If IsChartEmpty(objCO) Then objCO.Visible = False
Next objCO
End Sub
Private Function IsChartEmpty(co As ChartObject) As Boolean
Dim i As Integer
Dim j As Integer
Dim objSeries As Series
For i = 1 To co.Chart.SeriesCollection.Count
Set objSeries = co.Chart.SeriesCollection(i)
For j = 1 To UBound(objSeries.Values)
If objSeries.Values(j) <> 0 Then
IsChartEmpty = False
Exit Function
End If
Next j
Next i
IsChartEmpty = True
End Function
An outdated pivotcache and some still remembered but in the meantime missed items caused some trouble to me in the past. So I propose to add this code once before:
Dim pc As PivotCache
For Each pc In ThisWorkbook.PivotCaches
pc.MissingItemsLimit = xlMissingItemsNone
pc.Refresh
Next pc
I'm trying to determine if a named range has been set via VBA. The named range is called LoadedToken and essentially is loaded when a user clicks a particular button. I use this as proof that initialisation has taken place.
I have a function to check if this has taken place:
Function ToolIsEnabled()
' We check if the R2A add-in has been loaded by detecting the named range
If ActiveWorkbook.Names("LoadedToken") Is Nothing Then
ToolIsEnabled = False
Else
ToolIsEnabled = True
End If
End Function
and I get an application error. Of course, the VBA is incorrect. However how can I actually accomplish this?!
Sub Test()
Debug.Print IsNamedRange("Bumsti")
End Sub
Function IsNamedRange(RName As String) As Boolean
Dim N As Name
IsNamedRange = False
For Each N In ActiveWorkbook.Names
If N.Name = RName Then
IsNamedRange = True
Exit For
End If
Next
End Function
Usage in OP context could be
' ...
If IsNamedRange("LoadedToken") Then
' ...
End If
' ...
or - if a program specific Bool needs to be set
' ...
Dim IsTokenLoaded as Boolean
IsTokenLoaded = IsNamedRange("LoadedToken")
' ...
Both constructs make it pretty clear in the source code what you are aiming for.
You can achieve this by using error handling:
Function ToolIsEnabled() As Boolean
Dim rng As Range
On Error Resume Next
Set rng = ActiveWorkbook.Range("LoadedToken")
On Error GoTo 0
ToolIsEnabled = Not rng is Nothing
End Function
This will check either in ThisWorkbook or a named workbook and return TRUE/FALSE.
Sub Test()
MsgBox NamedRangeExists("SomeName")
MsgBox NamedRangeExists("SomeOtherName", Workbooks("Book1.xls"))
End Sub
Public Function NamedRangeExists(sName As String, Optional Book As Workbook) As Boolean
On Error Resume Next
If Book Is Nothing Then
Set Book = ThisWorkbook
End If
NamedRangeExists = Book.Names(sName).Index <> (Err.Number = 0)
On Error GoTo 0
End Function
Edit:
A shorter version if it's only going to look in ThisWorkbook:
Public Function NamedRangeExists(sName As String) As Boolean
On Error Resume Next
NamedRangeExists = ThisWorkbook.Names(sName).Index <> (Err.Number = 0)
On Error GoTo 0
End Function
For the activeworkbook, you could also call the old XLM NAMES() function:
Function IsNameInActiveWorkbook(sName As String) As Boolean
IsNameInActiveWorkbook = Not IsError(Application.ExecuteExcel4Macro("MATCH(""" & sName & """,NAMES(),0)"))
End Function
As per Tom's answer these 2 line should do the trick:
On Error Resume Next
Set TestRange = ActiveWorkbook.Range("LoadedToken") 'if it does **not** exist this line will be ERROR
I created code that will copy the RecordSet to Excel and I want a macro in the Excel file to run. The code works perfectly until it hits the code to run the macro. I must not be calling the application correctly but can't figure it out!
Private Sub Command233_Click()
Dim objXLS As Object
Dim wks As Object
Dim rsc As Recordset
Dim idx As Long
Set rsc = Me.RecordsetClone
If Me.RecordsetClone.RecordCount = 0 Then
MsgBox ("No Records To Export")
Else
rsc.MoveLast
rsc.MoveFirst
Set objXLS = CreateObject("Excel.Application")
objXLS.Workbooks.Open FileName:="C:\Comps Macro.xlsm", ReadOnly:=True
Set wks = objXLS.Worksheets(1)
For idx = 0 To rsc.Fields.Count - 1
wks.Cells(1, idx + 1).Value = rsc.Fields(idx).Name
Next
wks.Range(wks.Cells(1, 1), wks.Cells(1, rsc.Fields.Count)).Font.Bold = True
wks.Range("A2").CopyFromRecordset rsc, rsc.RecordCount, rsc.Fields.Count
objXLS.Visible = True
objXLS.Run ("Format")
End If
Set objXLS = Nothing
End Sub
The runtime error I am receiving is:
Run-Time Error '-2147417851 (80010105)':
Method 'Run' of object '_Application' failed
You have to reference the Sub or Function correctly.
Your Sub named Format is defined at Workbook- or Sheet- level?
If defined in a Sheet module (for example Sheet1):
objXLS.Run ("Sheet1.Format")
If at Workbook level:
objXLS.Run ("ThisWorkbook.Format")
Hope this helps