Excel VBA Global error handling - excel

Is there a way to do global error handling?
Can I put some code in the Workbook code that will catch any errors that occur within all modules?
I could put the same error handler in each module but I'm looking for something more general.
I ask because I have sheet names that are stored as global variables like this Sheets(QuoteName). If there is an error then these global variables are lost. I have a macro that will rename the global variables but I put this within Workbook_BeforeSave.
I want it to go to the global error handler and rename the global variable if I get a Subscript out of range error for Sheets(QuoteName)

As Sid already mentioned in the comment, there is no central error handler.
Best practice is to have a central error handling routine that gets called from the local error handlers. Take a look at the great MZ-Tools: it has the possibility to define a default error handler at the press of a button (Ctrl-E). You can customize this error handler - and it can also contain module and/or sub name!
Additionally, check out this post at Daily Dose of Excel. It is Dick Kusleika's OO version of the error handler proposed in this book (which I can highly recommend).

Here's some code I threw together to handle the problem in access
It puts error checking in all subs, but not functions. subs have to have a parent form (ACCESS), or alternatively, you have to put the form name in manually. subs that are continued over more than one line will be mercilessly whacked.
The two subs have to be at the bottom of a module.
globalerror is your error management routine
CleaVBA_click changes your VBA code, adds line #s to everything
globalerror looks at a boolean global errortracking to see if it logs everything or only errors
There is a table ErrorTracking that has to be created otherwise just comment out from 1990 to 2160
When running, it removes then adds line numbers to everything in the project, so your error message can include a line #
Not sure if it works on anything other than stuff I've coded.
Be sure to run and test on a copy of your VBA, because it literally rewrites every line of code in your project, and if I screwed up, and you didn't back up, then your project is broken.
Public Sub globalerror(Name As String, number As Integer, Description As String, source As String)
1970 Dim db As DAO.Database
1980 Dim rst As DAO.Recordset
1990 If errortracking Or (Err.number <> 0) Then
2000 Set db = CurrentDb
2010 Set rst = db.OpenRecordset("ErrorTracking")
2020 rst.AddNew
2030 rst.Fields("FormModule") = Name
2040 rst.Fields("ErrorNumber") = number
2050 rst.Fields("Description") = Description
2060 rst.Fields("Source") = source
2070 rst.Fields("timestamp") = Now()
2080 rst.Fields("Line") = Erl
2100 rst.Update
2110 rst.Close
2120 db.Close
2130 End If
2140 If Err.number = 0 Then
2150 Exit Sub
2160 End If
2170 MsgBox "ERROR" & vbCrLf & "Location: " & Name & vbCrLf & "Line: " & Erl & vbCrLf & "Number: " & number & vbCrLf & "Description: " & Description & vbCrLf & source & vbCrLf & Now() & vbCrLf & vbCrLf & "custom message"
2180 End Sub
Private Sub CleanVBA_Click()
Dim linekill As Integer
Dim component As Object
Dim index As Integer
Dim str As String
Dim str2a As String
Dim linenumber As Integer
Dim doline As Boolean
Dim skipline As Boolean
Dim selectflag As Boolean
Dim numstring() As String
skipline = False
selectflag = False
tabcounter = 0
For Each component In Application.VBE.ActiveVBProject.VBComponents
linekill = component.CodeModule.CountOfLines
linenumber = 0
For i = 1 To linekill
str = component.CodeModule.Lines(i, 1)
doline = True
If Right(Trim(str), 1) = "_" Then
doline = False
skipline = True
End If
If Len(Trim(str)) = 0 Then
doline = False
End If
If InStr(Trim(str), "'") = 1 Then
doline = False
End If
If selectflag Then
doline = False
End If
If InStr(str, "Select Case") > 0 Then
selectflag = True
End If
If InStr(str, "End Select") > 0 Then
selectflag = False
End If
If InStr(str, "Global ") > 0 Then
doline = False
End If
If InStr(str, "Sub ") > 0 Then
doline = False
End If
If InStr(str, "Option ") > 0 Then
doline = False
End If
If InStr(str, "Function ") > 0 Then
doline = False
End If
If (InStr(str, "Sub ") > 0) Then
If InStr(component.CodeModule.Lines(i + 1, 1), "On Error GoTo error") <> 0 Then
GoTo skipsub
End If
str2a = component.CodeModule.Name
index = InStr(str, "Sub ") ' sub
str = Right(str, Len(str) - index - 3) ' sub
' index = InStr(str, "Function ") ' function
' str = Right(str, Len(str) - index - 8) 'function
index = InStr(str, "(")
str = Left(str, index - 1)
varReturn = SysCmd(acSysCmdSetStatus, "Editing: " & str2a & " : " & str)
DoEvents
If (str = "CleanVBA_Click") Then
MsgBox "skipping self"
GoTo selfie
End If
If str = "globalerror" Then
MsgBox "skipping globalerror"
GoTo skipsub
End If
component.CodeModule.InsertLines i + 1, "On Error GoTo error"
i = i + 1
linekill = linekill + 1
component.CodeModule.InsertLines i + 1, "error:"
i = i + 1
linekill = linekill + 1
component.CodeModule.InsertLines i + 1, "Call globalerror(Me.Form.Name & """ & "-" & str & """, Err.number, Err.description, Err.source)"
i = i + 1
linekill = linekill + 1
component.CodeModule.InsertLines i + 1, " "
i = i + 1
linekill = linekill + 1
If (str = "MashVBA_Click") Then
MsgBox "skipping self"
MsgBox component.CodeModule.Name & " " & str
GoTo selfie
End If
Else
If skipline Then
If doline Then
skipline = False
End If
doline = False
End If
If doline Then
linenumber = linenumber + 10
numstring = Split(Trim(str), " ")
If Len(numstring(0)) >= 2 Then
If IsNumeric(numstring(0)) Then
str = Replace(str, numstring(0), "")
End If
End If
component.CodeModule.ReplaceLine i, linenumber & " " & str
End If
End If
skipsub:
Next i
selfie:
Next
varReturn = SysCmd(acSysCmdSetStatus, " ")
MsgBox "Finished"
End Sub

Related

VBA How to avoid recusrion when using many integers

I am trying to figure out how to avoid the multiple msgboxes which appear when I run my code:
Public Function IsItGood(aWord As Variant) As Boolean
Dim s As String
s = "|"
tmp = s & aWord & s
patern = ""
For i = 1 To 100
patern = patern & s & i
Next i
For i = 1 To 10
patern = patern & s & "C" & i
Next i
patern = patern & s & "merge|complete framed|width|border left|border right" & s
If InStr(1, patern, tmp) > 0 Then
IsItGood = True
Else
IsItGood = False
End If
End Function
Above is the function which is used in the below worksheet_change:
Sub Worksheet_Change(ByVal Target As Range)
Dim BigS As String
Dim arr As Variant
Dim a As Variant
If Intersect(Range("G3:G19"), Target) Is Nothing Then Exit Sub
arr = Split(Target, " ")
If IsItGood(a) Then
MsgBox (" In row" + Target.Address(0, 0)) & vbCrLf & a & vbCrLf + "are ok"
Else
MsgBox Target.Address(0, 0) & vbCrLf & a & vbCrLf & "has bad stuff"
Application.Undo
End If
End Sub
The first "for" loops the 100 integers and the second from C1 to C10 and the msgbox is repeated for each splitted string.Is there a way to prevent the multiple msgboxes so only one msgbox to appear at a time. And also an "out of stack space" error appears because of the recursion.
Set at the beginning: Application.EnableEvents = False and set it to True at the end. Recursion occurs, because you are calling macro on change event of workbook, which also generates this event, thus the method is calling itself, thus recursion.

VBA Dynamic Range VLOOKUP

I'm new to VBA and need get some help with a VLOOKUP?
I keep getting Compile error for Expected: end of statement
This is the line that is giving me problems.
I added the & sign after (row_number) and am now getting a run-time error '9': Subscript out of range error.
Sheets("WIP Count").Range("G" & (row_number)).Formula = "=VLOOKUP(C" & (row_number) & ",PRISM!L:T,8,FALSE)"
Here is the rest of the code.
Sub CommandButton1_Click()
q1_answer = Sheets("Tracker").Range("F8")
q2_answer = Sheets("Tracker").Range("F9")
q3_answer = Sheets("Tracker").Range("F10")
q4_answer = Sheets("Tracker").Range("F11")
If q1_answer = "" Then
MsgBox "Fill in Name"
Exit Sub
End If
If q2_answer = "" Then
MsgBox "Fill in Serial Number"
Exit Sub
End If
If q3_answer = "" Then
MsgBox "Fill in Part Number"
Exit Sub
End If
If q4_answer = "" Then
MsgBox "Fill in Quantity"
Exit Sub
End If
row_number = 1
Do
DoEvents
row_number = row_number + 1
item_in_review = Sheets("WIP_Count").Range("A" & row_number)
Loop Until item_in_review = ""
last_transaction_id = Sheets("WIP_Count").Range("A" & (row_number - 1))
Dim next_transaction_id As Integer
next_transaction_id = last_transaction_id + 1
Sheets("WIP_Count").Range("A" & (row_number)) = next_transaction_id
Sheets("WIP_Count").Range("B" & (row_number)) = q1_answer
Sheets("WIP_Count").Range("C" & (row_number)) = q2_answer
Sheets("WIP_Count").Range("D" & (row_number)) = q3_answer
Sheets("WIP_Count").Range("E" & (row_number)) = q4_answer
Sheets("WIP_Count").Range("F" & (row_number)).Value = Date
Sheets("WIP Count").Range("G" & (row_number)).Formula = "=VLOOKUP(C" & (row_number) & ",PRISM!L:T,8,FALSE)"
Sheets("Tracker").Range("F8") = ""
Sheets("Tracker").Range("F9") = ""
Sheets("Tracker").Range("F10") = ""
Sheets("Tracker").Range("F11") = ""
MsgBox "Done"
End Sub

Excel VBA looping Help Needed

I need this macro to automatically grab the data from column A, find the data into the path given and replace it with column B. It is working but I need it to work just for once and goes on forward automatically..
Can anyone help me in this..
Sub UnkownFunctionName()
Dim myfolder
Dim Fnd As String, Rplc As String
Fnd = Application.InputBox(prompt:="Find string:", Title:="Rename files and folders", Type:=2)
Rplc = Application.InputBox(prompt:="Replace with:", Title:="Rename files and folders", Type:=2)
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With
Call Recursive(myfolder, Fnd, Rplc)
End Sub
Sub Recursive(FolderPath As Variant, Fnd As String, Rplc As String)
Dim Value As String, Folders() As String, Fname As String, Fext As String, Mtxt As String
Dim x As Integer
Dim Folder As Variant, a As Long
ReDim Folders(0)
If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
On Error Resume Next
Mtxt = "Rename folder " & Value & " to " & WorksheetFunction.Substitute(Value, Fnd, Rplc) & "?"
x = MsgBox(Mtxt, vbYesNoCancel)
If x = vbCancel Then Exit Sub
If x = vbYes Then
Name FolderPath & Value As FolderPath & WorksheetFunction.Substitute(Value, Fnd, Rplc)
End If
Value = WorksheetFunction.Substitute(Value, Fnd, Rplc)
If Err <> 0 Then
MsgBox "Error"
Exit Sub
End If
On Error GoTo 0
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
Else
On Error Resume Next
Fext = Split(Value, ".")(UBound(Split(Value, ".")))
Fname = Left(Value, Len(Value) - Len(Split(Value, ".")(UBound(Split(Value, ".")))) - 1)
Fname = WorksheetFunction.Substitute(Fname, Fnd, Rplc)
If Value <> (Fname & "." & Fext) Then
Mtxt = "Rename file " & Value & " to " & Fname & "." & Fext & "?"
x = MsgBox(Mtxt, vbYesNoCancel)
If x = vbCancel Then Exit Sub
If x = vbYes Then
Name FolderPath & Value As FolderPath & Fname & "."& Fext
End If
End If
If Err <> 0 Then
MsgBox "Error"
Exit Sub
End If
On Error GoTo 0
End If
End If
Value = Dir
Loop
For Each Folder In Folders
Call Recursive(FolderPath & Folder & "\", Fnd, Rplc)
Next
End Sub
If this accomplishes what you want, why not put a pause of some kind after the loop that accomplishes your goal completes. For instance-
...
End If
If MsgBox("Continue?", vbYesNo, "Confirm") = vbNo Then Exit Sub
...
I'm having a hard time linking what the code does to what your question suggests. It seems that the code renames files and folders. Can you explain a bit more about your goal?

Can I rename every combobox with same name in excel?

There are a lot of combobox in sheet and they are appending dynamic. But all of combobox' assignments are same. They will run a function in macro. Can I rename all of combobox with same name? Or how can I do what I want?
Sub ekranadi()
Dim mainworkBook As Workbook
Set mainworkBook = ActiveWorkbook
For i = 1 To mainworkBook.Sheets.Count
If Left(mainworkBook.Sheets(i).Name, 5) = "Ekran"
Then ComboBoxEkranAdı.AddItem mainworkBook.Sheets(i).Name
End If
Next i
End Sub
If my understanding of your requirement is correct, the macro below will show you how to achieve the effect you seek.
A user form has a collection named Controls that contains every control on the form. Instead of MyControl.Name you can write Controls(6).Name if 6 is the index number within Controls of MyControl.
The macro below outputs the index number, type name and name of every control on a form. If the control is a ComboBox, it adds three items to it with each item value being unique to the box.
Edit
Sorry I did not read your question carefully enough. I do not use controls on worksheets because I consider controls on user forms to be more powerful and more convenient. Controls on worksheets are further complicated by having two types: those loaded from the Controls toolbox and those loaded from the Forms toolbox. Functionality depends on which type you have.
To test the new macro DemoWorksheet, I loaded worksheet "Test" with both types of control. The macro shows how to fill both type of combo box via their collections.
Option Explicit
Sub DemoUserForm()
Dim InxCtrl As Long
Load UserForm1
With UserForm1
For InxCtrl = 0 To .Controls.Count - 1
Debug.Print Right(" " & InxCtrl, 2) & " " & _
Left(TypeName(.Controls(InxCtrl)) & Space(10), 15) & _
.Controls(InxCtrl).Name
If TypeName(.Controls(InxCtrl)) = "ComboBox" Then
With .Controls(InxCtrl)
.AddItem InxCtrl & " A"
.AddItem InxCtrl & " B"
.AddItem InxCtrl & " C"
End With
End If
Next
End With
UserForm1.Show
End Sub
Sub DemoWorksheet()
Dim Inx As Long
With Worksheets("Test")
Debug.Print "Shapes.Count=" & .Shapes.Count
Debug.Print "OLEObjects.Count=" & .OLEObjects.Count
For Inx = 1 To .Shapes.Count
With .Shapes(Inx)
Debug.Print "S " & Right(" " & Inx, 2) & " ShapeType=" & _
ShapeTypeName(.Type) & " Name=" & .Name
If .Type = msoFormControl Then
Debug.Print " FormControlType=" & FormControlTypeName(.FormControlType)
If .FormControlType = xlDropDown Then
.ControlFormat.AddItem "S " & Inx & " A"
.ControlFormat.AddItem "S " & Inx & " B"
.ControlFormat.AddItem "S " & Inx & " C"
.ControlFormat.DropDownLines = 3
End If
End If
End With
Next
For Inx = 1 To .OLEObjects.Count
With .OLEObjects(Inx)
Debug.Print "O " & Right(" " & Inx, 2) & " OleType=" & _
OLETypeName(.OLEType) & " Name=" & .Name
If Left(.Name, 8) = "ComboBox" Then
.Object.AddItem "O " & Inx & " A"
.Object.AddItem "O " & Inx & " B"
.Object.AddItem "O " & Inx & " C"
End If
End With
Next
End With
End Sub
Function FormControlTypeName(ByVal FCType As Long) As String
Dim Inx As Long
Dim TypeName() As Variant
Dim TypeNumber() As Variant
TypeName = Array("ButtonControl", "CheckBox", "DropDown", "EditBox", "GroupBox", _
"Label", "ListBox", "OptionButton", "ScrollBar", "Spinner")
TypeNumber = Array(xlButtonControl, xlCheckBox, xlDropDown, xlEditBox, xlGroupBox, _
xlLabel, xlListBox, xlOptionButton, xlScrollBar, xlSpinner)
For Inx = 0 To UBound(TypeNumber)
If FCType = TypeNumber(Inx) Then
FormControlTypeName = TypeName(Inx)
Exit Function
End If
Next
FormControlTypeName = "Unknown"
End Function
Function OLETypeName(ByVal OType As Long) As String
If OType = xlOLELink Then
OLETypeName = "Link"
ElseIf OType = xlOLEEmbed Then
OLETypeName = "Embed"
ElseIf OType = xlOLEControl Then
OLETypeName = "Control"
Else
OLETypeName = "Unknown"
End If
End Function
Function ShapeTypeName(ByVal SType As Long) As String
Dim Inx As Long
Dim TypeName() As Variant
Dim TypeNumber() As Variant
TypeName = Array("AutoShape", "Callout", "Canvas", "Chart", "Comment", "Diagram", _
"EmbeddedOLEObject", "FormControl", "Freeform", "Group", "Line", _
"LinkedOLEObject", "LinkedPicture", "Media", "OLEControlObject", _
"Picture", "Placeholder", "ScriptAnchor", "ShapeTypeMixed", _
"Table", "TextBox", "TextEffect")
TypeNumber = Array(msoAutoShape, msoCallout, msoCanvas, msoChart, msoComment, msoDiagram, _
msoEmbeddedOLEObject, msoFormControl, msoFreeform, msoGroup, msoLine, _
msoLinkedOLEObject, msoLinkedPicture, msoMedia, msoOLEControlObject, _
msoPicture, msoPlaceholder, msoScriptAnchor, msoShapeTypeMixed, _
msoTable, msoTextBox, msoTextEffect)
For Inx = 0 To UBound(TypeNumber)
If SType = TypeNumber(Inx) Then
ShapeTypeName = TypeName(Inx)
Exit Function
End If
Next
ShapeTypeName = "Unknown"
End Function

Global variable in userforms does not work

I am creating userforms. Userforms are pretty connected to each other - use informations one from another. So... I thought about creating few global variables to make my life easier:
Public nazwa_arkusza As String
Public skoroszyt As Workbooks
Public arkusz As Worksheet
They are wrote in Useform Klient_kraj. Edytuj is Combobox within Klient_kraj Userform. I want to execute arkusz variable in different userform, but I get run-time error: "Object does not support this method"
Private Sub but_next_Click()
Dim Faktura As Range, faktury_range As Range
Dim LastRow As Integer
LastRow = Klient_kraj.skoroszyt.arkusz.Cells(Rows.Count, 1).End(xlUp).Row 'error line
Set faktury_range = skoroszyt.Range("A1:A" & LastRow)
(...)
end sub
.
Private Sub edytuj_Click()
Dim nazwa As String
nazwa_arkusza = kraj.List(kraj.ListIndex, 1) & " " & Mid(okres1.Value, 4, 2) & Mid(okres2.Value, 3, 3)
nazwa = "C:\1\" & klient.Text & ".xlsx"
'Jeżeli kraj nie wybrany = msgbox
If kraj.Value = "" Then
MsgBox ("Nie wybrałeś kraju")
Exit Sub:
Else
If okres1.Value = "" Or okres2.Value = "" Then
MsgBox ("Nie wybrałeś okresu rozliczeniowego")
Exit Sub:
End If
End If
'Jeżeli nie ma pliku - utwórz nowy
If Dir(nazwa) = "" Then
Workbooks.Add(1).SaveAs Filename:="C:\1\" & klient.Text, FileFormat:=51
Worksheets(1).Name = nazwa_arkusza
Else
'Jeżeli nie jest otwarty - otwórz
On Error GoTo niema_pliku:
If GetObject(, "Excel.Application").Workbooks(Klient_kraj.klient.Text & ".xlsx") Is Nothing Then
Workbooks.Open Filename:="C:\1\" & klient.Text & ".xlsx"
Else
Workbooks(Klient_kraj.klient.Text).Activate
End If
End If
Set skoroszyt = Workbooks(Klient_kraj.klient.Text & ".xlsx")
'Jeżeli arkusz nie istnieje - utwórz; istnieje - aktywuj
On Error GoTo niema_arkusza:
If skoroszyt.Worksheets(nazwa_arkusza).Name = "" Then
Else
skoroszyt.Worksheets(nazwa_arkusza).Activate
End If
On Error GoTo 0
Set arkusz = Sheets(nazwa_arkusza)
Application.Windows(klient.Text & ".xlsx").Visible = False
Faktura.Show
niema_pliku:
If Err.Number = 9 Then
Resume Next
End If
niema_arkusza:
If Err.Number = 9 Then
skoroszyt.Worksheets.Add.Name = nazwa_arkusza
skoroszyt.Worksheets(nazwa_arkusza).Activate
Resume Next
End If
End Sub
This variable will also be used in different userform.
What am I doing wrong?

Resources