returning object that caused error to a global errorhandler - vba

i have written the following code which uses a global errorhandler that rectifies the error and resumes code again. right now i have labelled the lines and using 'Erl', i am checking which line caused the error and then accordingly finding the object and creating it.
What i want to do is to pass the object that caused the error to the errorhandler itself and then create that object and return control back to main procedure to resume from where it left off.
How to return the object that caused the error to an error handler? this way it would be more appropriate to handle some errors, instead of just returning an error message and error description.
as an example, i am letting the errorhandler handle creation of sheets if they are non-existent.
Option Explicit
'Worksheets: Public to VBproject as it may be used in almost every module.
Public WSCombined As Worksheet
Public WSResult As Worksheet
'Worksheet names: VBPublic to project as it may be used in almost every module.
Public Const Combined As String = "Combined data"
Public Const Result As String = "Result"
'Array: Public to VBproject as it may be used in almost every module.
Public Arr() As Variant
Sub Main()
On Error GoTo ERRHANDLER
Dim Rng As Range
With ThisWorkbook
'error labels for passing to Erl, so that corresponding sheet names can then be selected for sheet objects.
10001: Set WSCombined = .Sheets(Combined)
10002: Set WSResult = .Sheets(Result)
10003: Set Rng = WSCombined.Rows(1).EntireRow
10004: Arr = Rng
End With
EXITSUB:
' cleanup
Set WSCombined = Nothing
Set WSResult = Nothing
Exit Sub
ERRHANDLER:
If ErrorHandling(Err, ThisWorkbook, Erl) Then
GoTo EXITSUB
Else
Resume
End If
End Sub
Function ErrorHandling(objError As Object, Optional WB As Workbook, Optional ERlCode As Long) As Boolean
With objError
Select Case .Number
Case Is = 9 'subscript out of range
Select Case ERlCode
Case Is = 10001 ' Worksheet: for Combined sheet
Call SheetExists(WB, Combined)
Case Is = 10002 ' Worksheet: for Result sheet
Call SheetExists(WB, Result)
Case Is = 10003 ' Array: Array not initialized
Call IsArrayAllocated(Arr)
Case Else
End Select
ErrorHandling = False ' resume again at same line, after sheet has been created.
Case Is = 91 ' Object variable or with variable not found
Call IsArrayAllocated(Arr)
Case Is = ""
Case Else
MsgBox objError.Number & " - " & objError.Description
ErrorHandling = True
End Select
End With
objError.Clear
On Error GoTo 0
End Function
Function SheetExists(WBook As Workbook, SHTName As String) As Worksheet
On Error GoTo ERRHANDLE
With WBook
Set SheetExists = .Sheets(SHTName)
End With
EXITFUNC:
Exit Function
ERRHANDLE:
With WBook
Dim Sh As Worksheet
Set SheetExists = .Sheets.Add
SheetExists.Name = SHTName
End With
Resume EXITFUNC
End Function
Function IsArrayAllocated(Arr As Variant) As Variant
'Courtesy: #Chip Pearson
' check if array is initialized, if not initialize it
On Error GoTo ERRHANDLE
IsArrayAllocated = (IsArray(Arr) And Not IsError(LBound(Arr, 1)) And LBound(Arr, 1) <= UBound(Arr, 1))
EXITFUNC:
Exit Function
ERRHANDLE:
ReDim Arr(0 To 0)
IsArrayAllocated = Arr
GoTo EXITFUNC
End Function
To tackle some errors, the other way i was thinking is to just have functions created which could have their own error handling code and rectify the error in place itself, instead of passing it to a global error handler of main proc.
e.g.
Sub Main()
On Error GoTo ERRHANDLER
Dim Rng As Range
With ThisWorkbook
set WSCombined = SheetExists(ThisWorkbook, Combined)
Set WSResult = SheetExists(ThisWorkbook, Result)
....
....
Function SheetExists(WBook As Workbook, SHTName As String) As Worksheet
On Error GoTo ERRHANDLE
With WBook
Set SheetExists = .Sheets(SHTName)
End With
EXITFUNC:
Exit Function
ERRHANDLE:
With WBook
Dim Sh As Worksheet
Set SheetExists = .Sheets.Add
SheetExists.Name = SHTName
End With
Resume EXITFUNC
End Function
Any help would be most appreciated.

One answer to your specific question is to use another global object to store the object that threw the error in:
Public LastErrorObject As Object
Sub Main()
With ThisWorkbook
Set LastErrorObject = ThisWorkbook
Set WSCombined = .Sheets(Combined)
End With
End Sub
However, this is incredibly cumbersome, because you need to keep track of it everywhere. Also, it still doesn't do much in the way of giving you the context for the error.
Your second idea is much better, and doesn't abuse the error handler as much because it both acknowleges that there may be an error and actively seeks to avoid errors instead of passively trying to deal with them. For example, instead of indexing into ActiveWorkbook.Worksheets() directly, you can do something like this to make sure you get a new sheet back:
Private Function GetOrCreateWorksheet(book As Workbook, name As String) As Worksheet
On Error GoTo ForceNew
Dim result As Worksheet
Set result = book.Worksheets(name)
ForceNew:
If Err.Number = 9 Then
Set result = book.Worksheets.Add()
result.name = name
ElseIf Err.Number <> 0 Then
Err.Raise Err.Number, Err.source, Err.Description
End If
Set GetOrCreateWorksheet = result
End Function
Note that the error handling is only checking for the one specific error that you'll get if the sheet doesn't exit (Subscript out of range).
BTW and off topic, your Select Case syntax is overly convoluted - you only need to specify the case and can leave out the Is = syntax. It is also much easier to read with another level of indentation:
Select Case ERlCode
Case 10001
'...
Case 10002
'...
Case Else
'...
End Select

Related

VBA Code for Vlookup on different worksheets within the same workbook

I am trying to write a vba script that will allow me to vlookup values from Sheet(3) to different Sheet(i) - and paste it on range"R2" on the Sheet(i) - I also want it to go to the end of the values in Column M on Sheet(i) [if this is possible]. I basically want to run through all the different "i" sheets on the workbook. Sheet (3) has all the data that needs to be copied on all the other "i" sheets.
I keep getting an error with my code below.
Sub CopyTableau1Data()
Dim wka As Worksheet
Dim wkb As Worksheet
ShtCount = ActiveWorkbook.Sheets.Count
For i = 9 To ShtCount
With ThisWorkbook
Set wka = .Sheets(i)
Set wkb = .Sheets(3)
End With
Worksheets(i).Activate
If IsError(Application.WorksheetFunction.VLookup(wka.Range("M2"), wkb.Range("E:T"), 14, 0)) Then
wka.Range("R2").Value = ""
Else
wka.Range("R2").Value = Application.WorksheetFunction.VLookup(wka.Range("M2"), wks.Range("E:T"), 14, 0)
End If
Next i
End Sub
IsError does not work with Application.WorksheetFunction.VLookup or WorksheetFunction.VLookup, only with Application.VLookup.
It is faster and easier to return Application.Match once to a variant type variable and then test that for use.
dim am as variant
'are you sure you want wkb and not wks here?
am = Application.match(wka.Range("M2"), wkb.Range("E:E"), 0)
If IsError(am) Then
wka.Range("R2") = vbnullstring
Else
'are you sure you want wks and not wkb here?
wka.Range("R2") = wks.cells(am, "R").value
End If
Note the apparent misuse of wkb and wks in two places. I don't see the point of looking up a value in one worksheet, testing that return then using the results of the test to lookup the same value in another worksheet.
You can use the following code:
Sub CopyTableau1Data()
Dim wka As Worksheet
Dim wkb As Worksheet, i As Integer
ShtCount = ActiveWorkbook.Sheets.Count
For i = 9 To ShtCount
With ThisWorkbook
Set wka = .Sheets(i)
Set wkb = .Sheets(3)
End With
Worksheets(i).Activate
wka.Range("R2") = aVL(i)
Next i
End Sub
Function aVL(ByVal wsno As Integer) As String
On Error GoTo errhandler:
aVL =
Application.WorksheetFunction.VLookup(ActiveWorkbook.Worksheets(wsno).Range("M2"),
ActiveWorkbook.Worksheets(3).Range("E:T"), 14, False)
errhandler:
aVL = ""
End Function
When you try to check an error by isError, program flow can immediately return from the sub depending on the error. You could use on error in your sub to prevent that but this would only handle the first error. By delegating the error handling to a function you can repeatedly handle errors in your loop.
I assumed you wanted to use wkb.Range("E:T") instead of wks.Range("E:T").

Activate sheet 1 otherwise another sheet

Hi I tried to modify the following two lines of code by adding an if statement, but it didn't work. Does anyone know why?
Workbooks(wkbk_Record).Activate
Workbooks(wkbk_Record).Sheets("Tab1").Select
What's wrong with the following? Thank you
If SheetExists("Tab1", Workbooks(wkbk_Record)) Then
Workbooks(wkbk_Record).Activate
Workbooks(wkbk_Record).Sheets("Tab1").Select
Else
Workbooks(wkbk_Record).Activate
Workbooks(wkbk_Record).Sheets("Tab2").Select
Considering that you take the SheetExists from here - Test or check if sheet exists this is something that works:
Sub TestMe()
If SheetExists("Tab1") Then
Sheets("Tab1").Select
ElseIf SheetExists("Tab2") Then
Sheets("Tab2").Select
Else
MsgBox "No Sheet"
End If
End Sub
Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function
Or if you wanna see your colleagues get crazy, write it like this:
Sub ActivateTab2OrTab1()
On Error Resume Next
Sheets("Tab2").Select
Sheets("Tab1").Select
End Sub

Using Worksheet.Change event to add a new worksheet

I have a range of cells (specifically D6:D34) where all the values in the cells have a corresponding sheet. However, since I've been just manually adding worksheets when I add a new value (or change a cell value), I'm thinking about using Private Sub Worksheet_Change(ByVal Target as Range) to allow the automatic creation of a worksheet when the cells change. This is what I've tried to use, but now I'm getting an error that the "sheet name already exists" as it looks down the whole column. I've tried using error handling to skip over ones that exist, but it ends up moving to the next one to check but leaving "Sheet1" and "Sheet2", etc. Any suggestions on how to set this up?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim hlValue As Range
For Each hlValue In Sheets(1).Range("D6:D34")
ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = hlValue
Next
End Sub
I should also say that if one of the cell value is deleted, the worksheet should be deleted as well. Some sort of If CellValue <> Exist, Delete? I couldn't find anything to use to check if it exists besides fancy functions. Should I use one of these?
EDIT: Okay, I've got this now. This should suffice.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.DisplayStatusBar = True
Application.ScreenUpdating = False 'Run faster
Application.DisplayAlerts = False 'Just in case
Dim shtName As Variant
For Each shtName In Sheets(1).Range("D6:D34")
If WorksheetExists((shtName)) Then
'do nothing
Else
ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = shtName
Application.StatusBar = "Creating new sheet for " & shtName 'Just in case it's running slowly
Sheets("Admin").Select
End If
Next
Application.StatusBar = "READY"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function WorksheetExists(sName As String) As Boolean
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
I couldn't find anything to use to check if it exists besides fancy functions. Should I use one of these?
Yes, you should! Worksheets are part of a Collection object and there is no built-in Exists (or similar) method that you can query. Such a function is not fancy :) and it would be a good introduction to using functions and/or calling other subroutines, if you're not familiar with that already.
At it's simplest:
Function SheetExists(sName As String) As Boolean
Dim w as Worksheet
On Error Resume Next
Set w = Worksheets(sName)
SheetExists = Not w Is Nothing
End Function
How this works:
If SheetExists("sheet1") Then
'Do something
Else
'Sheet doesn't exist, so do something else
End If
You pass a string value to the function as sName. THe function then returns True or False whether this sheet exists.
First, the function SheetExists attempts to set a Worksheet variable to the specified worksheet, by name. This will predictably fail if the worksheet name doesn't exist, so we use this knowledge along with the Resume Next statement. In the case of an error, w will not be assigned a worksheet and will remain a Nothing, and then we use a boolean expression (Not w Is Nothing) as the function's return value. If the sheet does exist, w will not be nothing, so the function will return True, and if the sheet doesn't exist, w will be Nothing, so the function will return False.
The function above only uses the ActiveWorkbook, so a more robust version of this would also allow you to specify a parent workbook.
Function SheetExists(sName As String, Optional wb as Workbook = Nothing) As Boolean
'This function checks whether worksheet 'sName' exists in
' workbook object 'wb'. If no parameter is passed for 'wb' then
' assume to use the ActiveWorkbook
Dim w as Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
Set w = wb.Worksheets(sName)
SheetExists = Not w Is Nothing
End Function
NB: There are relatively few cases where On Error Resume Next is not frowned upon, but using this in a very small and specific Function, with a well-defined purpose and expectation is OK.
Alternatively, brute force iteration over the collection's Items may also be used to query collections for existence, and this does not rely on On Error Resume Next:
Function SheetExists2(sName as String) As Boolean
Dim ws as Worksheet, ret as Boolean
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = sName Then
ret = True
Exit For
End If
Next
SheetExists2 = ret
End Function

Type mismatch on query to create an array from list

I am running some VBa code in Excel to update multiple sheets, based on a list of sheets names.
Sub Test()
Dim ArrayOne As Variant
ArrayOne = ActiveSheet.Range("A8:A10")
Dim sheetsArray As Sheets
Set sheetsArray = ActiveWorkbook.Sheets(ArrayOne)
Dim target As Range
Dim sheetObject As Worksheet
' change value of range 'a1' on each sheet from sheetsArray
For Each sheetObject In sheetsArray
Set target = sheetObject.Range("A1")
target.Value = "Test"
Next sheetObject
End Sub
Here is my code, unfortuantly it errors: Type Mismatch on the following line of code
Set sheetsArray = ActiveWorkbook.Sheets(ArrayOne)
I'm understanding that you want to update the same cells in each worksheet, based on a list of worksheets that is contained in an Excel Range (A8:A10).
Try the following code:
Public Sub test()
Dim wks As Worksheet
Dim WksCell As Range
' Turn on inline Error Handling
On Error Resume Next
' Look at each cell within the range and obtain worksheet names
For Each WksCell In ActiveSheet.Range("A8:A10").Cells
' Attempt to reference the worksheet using this name
Set wks = Excel.Worksheets(WksCell.Value)
' Check if a "SubScript out of range" error occurred
' If so, it indicates that the sheet name does not exist
If Err.Number = 9 Then
' Set its style to Bad and move on
WksCell.Style = "Bad"
Err.Clear
Else
' For each worksheet, execute our logic
wks.Range("A1").Value = "Testing"
End If
' If any other error occurred, report it to the user and exit
If Err.Number <> 0 And Err.Number <> 9 Then
MsgBox "An error has occurred. Error #" & Err.Number & vbCr & _
Err.Description, vbCritical, "Error Encountered"
Set wks = Nothing
Exit For
End If
Next
' Return to normal error handling
On Error GoTo 0
Set wks = Nothing
End Sub
If you'd rather use it in a Macro then you can change the line
For Each WksCell In ActiveSheet.Range("A8:A10").Cells
to
For Each WksCell In Excel.Selection
which will use your current selection as the Worksheet list. Makes it more dynamic.
Hope that helps.

Runtime error "9" in VBA[excel] - Subscript out of range

I am currently working on a code that takes the date from the user, opens a calendar, sees if the month is present, and if it isn't, creates a worksheet with that month name.
The code looks like this where m_y is a string, and has values such as "January 2014" [the " signs included]:
Sub addmonth(m_y)
On Error Resume Next
CalendarWorkbook.Worksheets(m_y).Select
If Err.Number<>0 Then
'code to add sheet and format it
I tried putting it in a With/End With command, I have no Option Explicit in the code. Other methods mentioned in answers such as using the .Range() instead of the .Select; however I had no luck in succeeding.
Any help provided would be appreciated.
.Select in most cases is the main cause of runtime errors. I believe you have another workbook open. INTERESTING READ
Try this another way which doesn't use .Select
Option Explicit
Sub test()
addmonth ("""Feb2015""")
End Sub
Sub addmonth(m_y)
Dim calendarworkbook As Workbook
Dim ws As Worksheet
Set calendarworkbook = ThisWorkbook
On Error Resume Next
Set ws = calendarworkbook.Worksheets(m_y)
On Error GoTo 0
If ws Is Nothing Then calendarworkbook.Worksheets.Add.Name = m_y
End Sub
Note: OERN (On Error Resume Next) should be used judiciously. Ensure that it just curbs the message for only the part that you want and not for the rest. Else it is not good error handling :)
This worked for me
Sub test()
addmonth ("""Feb2015""")
End Sub
Sub addmonth(m_y)
Dim calendarworkbook As Workbook
Set calendarworkbook = ThisWorkbook
On Error Resume Next
calendarworkbook.Worksheets(m_y).Select
If Err.Number <> 0 Then
With calendarworkbook.Worksheets.Add
.Name = m_y
End With
End If
End Sub