I have the following code which uses two for loops (Prod and Dev)
There are many values in the array but i have taken only two for the example
What it does is, it copies the value from one excel to the other.
Now, there is a probability that file NSA_103_B_Roles.xls doesnot exist
In that case, i dont want the code to take any action, so i have put on error resume next
But still it is printing the value in the excel which doesnot exist,
What is the reason?
Private Sub CommandButton1_Click()
Prod = Array("ZS7_656", "PCO_656")
Dev = Array("NSA_103", "DCA_656")
For lngCounter1 = LBound(Dev) To UBound(Dev)
For lngCounter = LBound(Prod) To UBound(Prod)
On Error Resume Next
Set Zz2 = Workbooks.Open("C:\Users\*****\Desktop\New folder\" &
Dev(lngCounter1) & "_B_Roles.xls")
Zz2.Sheets(Dev(lngCounter1) & "_B_Roles").Range("A1").Value = "anirudh"
ThisWorkbook.Sheets(Prod(lngCounter)).Range("A2").Value =
Zz2.Sheets(Dev(lngCounter1) & "_B_Roles").Range("A1").Value
On Error GoTo 0
Next lngCounter
Next lngCounter1
End Sub
Try the code below, explanation inside the code's comments :
Private Sub CommandButton1_Click()
Dim Zz2 As Workbook
Prod = Array("ZS7_656", "PCO_656")
Dev = Array("NSA_103", "DCA_656")
For lngCounter1 = LBound(Dev) To UBound(Dev)
For lngCounter = LBound(Prod) To UBound(Prod)
' ==== this section starts the error handling ===
On Error Resume Next
Set Zz2 = Workbooks.Open("C:\Users\*****\Desktop\New folder\" & _
Dev(lngCounter1) & "_B_Roles.xls")
On Error GoTo 0
If Zz2 Is Nothing Then ' <-- unable to find the file
MsgBox "unable to find the specified file", vbCritical
Exit Sub
End If
' === Up to Here ===
Zz2.Sheets(Dev(lngCounter1) & "_B_Roles").Range("A1").Value = "anirudh"
ThisWorkbook.Sheets(Prod(lngCounter)).Range("A2").Value = Zz2.Sheets(Dev(lngCounter1) & "_B_Roles").Range("A1").Value
Next lngCounter
Next lngCounter1
End Sub
Related
I'm writing a procedure to update the components in one macro-enabled Excel workbook (Destination) from another macro-enabled Excel workbook (Source). The end result is to make the Destination components (worksheets, user forms, modules, etc.) match the Source components.
So far I have successfully (1) Added components from source that are not found in destination, (2) Replaced worksheet(s) with newer versions, (3) Globally updated the code in all modules, class modules and user forms, and (4) Updated miscellaneous cell formulas and values in various worksheets.
Where I have been struggling is deleting components in destination that are not found in source. I've been trying all kinds of approaches and believe I'm close but can't get past various errors in the actual VBComponents.Remove line. Here's my code:
Sub UpdateDest()
'Purpose:
'Sources: (1) https://www.excel-easy.com/vba/examples/import-sheets.html
' (2) https://stackoverflow.com/questions/16174469/unprotect-vbDestProject-from-vb-code
' (3) https://stackoverflow.com/questions/18497527/copy-vba-code-from-a-sheet-in-one-workbook-to-another
'=== Declare Variables
Dim booCompFound As Boolean
Dim cmSrc As CodeModule, cmDest As CodeModule
Dim xlWBDest As Excel.Workbook, xlWSDest As Excel.Worksheet
Dim xlWBSrc As Excel.Workbook, xlWSSrc As Excel.Worksheet
Dim i As Integer, j As Integer
Dim lngVBUnlocked As Long
Dim vbDestComp As Object, vbDestComps As Object, vbDestProj As Object, vbDestMod As Object
Dim vbSrcComp As Object, vbSrcComps As Object, vbSrcProj As Object, vbSrcMod As Object
Dim modModule As Object
Dim strDestName As String, strDestPath As String, strSrcName As String, strSrcPath As String
Dim strUpdName As String, strUpdPath As String
'On Error GoTo ErrorHandler
'=== Initialize Variables and Prepare for Execution
Application.ScreenUpdating = True
Application.DisplayAlerts = True
strUpdPath = ThisWorkbook.Path & "\"
'=== (Code execution)
'--- Select Dest and source workbooks for the update, and remove workbook, worksheet and VBA Project protection from both
strSrcPath = Application.GetOpenFilename(Title:="Select SOURCE workbook for the update", FileFilter:="Excel Files *.xls* (*.xls*),")
If strSrcPath = "" Then
MsgBox "No source workbook was selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Set xlWBSrc = Workbooks.Open(strSrcPath)
UnprotectAll xlWBSrc
'For Each xlWSSrc In xlWBSrc.Worksheets
' xlWSSrc.Visible = xlSheetVisible
'Next xlWSSrc
Set vbSrcProj = xlWBSrc.VBProject
lngVBUnlocked = UnlockProject(vbSrcProj, "FMD090")
Debug.Print lngVBUnlocked
If lngVBUnlocked <> 0 And lngVBUnlocked <> 2 Then
MsgBox "The source VB Project could not be unlocked.", vbExclamation, "Error!"
Exit Sub
Else
Set vbSrcComps = vbSrcProj.VBComponents
End If
End If
strDestPath = Application.GetOpenFilename(Title:="Select DESTINATION workbook to update", FileFilter:="Excel Files *.xls* (*.xls*),")
If strDestPath = "" Then
MsgBox "No destination workbook was selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Set xlWBDest = Workbooks.Open(strDestPath)
UnprotectAll xlWBDest
'For Each xlWSDest In xlWBDest.Worksheets
' xlWSDest.Visible = xlSheetVisible
'Next xlWSDest
Set vbDestProj = xlWBDest.VBProject
lngVBUnlocked = UnlockProject(vbDestProj, "FMD090")
Debug.Print lngVBUnlocked
If lngVBUnlocked <> 0 And lngVBUnlocked <> 2 Then
MsgBox "The destination VB Project could not be unlocked.", vbExclamation, "Error!"
Exit Sub
Else
Set vbDestComps = vbDestProj.VBComponents
End If
End If
'--- Add components from source that are not found in destination
For Each vbSrcComp In vbSrcComps
Debug.Print vbSrcComp.Name
booCompFound = False
For Each vbDestComp In vbDestComps
If vbSrcComp.Name = vbDestComp.Name Then
booCompFound = True
Exit For
End If
Next vbDestComp
If booCompFound = False Then
Application.EnableEvents = False
vbSrcComp.Export strSrcPath & vbSrcComp.Name
vbDestComps.Import strSrcPath & vbSrcComp.Name
Kill strSrcPath & vbSrcComp.Name
Application.EnableEvents = True
End If
Next vbSrcComp
'--- Delete components in destination that are not found in source
Set vbDestComps = vbDestProj.VBComponents
For i = vbDestComps.Count To 1 Step -1
'For Each vbDestComp In vbDestComps
booCompFound = False
For Each vbSrcComp In vbSrcComps
Debug.Print "Src: "; vbSrcComp.Name; " Dest: "; vbDestComps(i).Name
If vbDestComps(i).Name = vbSrcComp.Name Then
booCompFound = True
Exit For
End If
Next vbSrcComp
If booCompFound = False Then
Application.EnableEvents = False
'>>> PROBLEM LINE
vbDestProj.VBComponents.Remove vbDestComps(i)
'<<<
Application.EnableEvents = True
End If
'Next vbDestComp
Next i
'--- Replace worksheet(s) with newer versions
strUpdName = "Lists_WS_3_1.xlsx"
If Dir(strUpdPath & strUpdName) <> "" Then
Application.EnableEvents = False
Set xlWBSrc = Workbooks.Open(strUpdPath & strUpdName)
xlWBDest.Worksheets("Lists").Visible = xlSheetVisible
Application.DisplayAlerts = False
xlWBDest.Worksheets("Lists").Name = "Lists_Old"
xlWBSrc.Worksheets("Lists").Copy After:=xlWBDest.Worksheets("FYMILES")
xlWBDest.Worksheets("Lists_Old").Delete
xlWBSrc.Close
Application.EnableEvents = True
Else
MsgBox "The file " & strUpdName & " is missing.", vbExclamation, "File Missing!"
Exit Sub
End If
'--- Globally update code in modules, class modules and user forms
For Each vbSrcComp In vbSrcComps
Set cmSrc = vbSrcComp.CodeModule
Debug.Print vbSrcComp.Name
Set cmDest = vbDestComps(vbSrcComp.Name).CodeModule
If cmSrc.CountOfLines > 0 Then
Application.EnableEvents = False
cmDest.DeleteLines 1, cmDest.CountOfLines 'Delete all lines in Dest component
cmDest.AddFromString cmSrc.Lines(1, cmSrc.CountOfLines) 'Copy all lines from source component to Dest component
Application.EnableEvents = True
End If
Next vbSrcComp
'--- Update miscellaneous cell formulas and values
Application.EnableEvents = False
xlWBDest.Sheets("Inventory Data and July").Range("E2").Formula = "=TEXT(Lists!$O$5, " & Chr(34) & "000" & Chr(34) & ")"
Application.EnableEvents = True
'=== Error Handling
ErrorHandler:
Application.EnableEvents = True
'=== Release Variables and Cleanup
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The problem code is about 2/3rds of the way down following '>>> PROBLEM LINE. This line of code produces a run-time error 5, invalid procedure call or argument when attempting to delete the Sheet18 code module.
During the run the original Sheet16 (Lists) is removed and replaced with a new Lists worksheet that Excel numbers Sheet18. After a weekend of contemplation I believe the issue stems from component naming. Attempting to address this, the code references the component names, but VB Properties for the new sheet are (Name) = (Sheet18) and Name = Lists (note the parentheses).
I've now tried saving the workbook following each operation without any change in the error or on what part of the structure the error occurs.
As it is currently written I'm looping backward through the destination components collection and attempting to delete when a component in Destination isn't found in Source. Commented out are the remnants of the original forward loop that also didn't work. I've tried many variations and either get an invalid procedure call or that the property or method isn't found in the object.
I've spend a day playing with this. Please take a look and help me see the light!
I'm running Excel 2016
Following on # Comintern's comment, I added tests to ensure the Remove method was only applied to non-document modules. This is the rewritten code block for removing the modules:
'--- Delete non-document components in destination that are not found in source
Set vbDestComps = vbDestProj.VBComponents
For Each vbDestComp In vbDestComps
If vbDestComp.Type >= 1 And vbDestComp.Type <= 3 Then
booCompFound = False
For Each vbSrcComp In vbSrcComps
Debug.Print "Src: "; vbSrcComp.Name; " Dest: "; vbDestComp.Name; " Type: "; vbDestComp.Type
If vbDestComp.Name = vbSrcComp.Name Then
booCompFound = True
Exit For
End If
Next vbSrcComp
If booCompFound = False Then
Application.EnableEvents = False
vbDestProj.VBComponents.Remove vbDestComp
Application.EnableEvents = True
End If
End If
Next vbDestComp
I am looking for a solution to select some slides and cut or copy and paste at another location while keeping the section information.
I have seen PPT does not support it out of the box (see http://answers.microsoft.com/en-us/office/forum/office_2013_release-powerpoint/copying-sections-to-a-new-powerpoint/2c723b0d-d465-4ab6-b127-6fdfc195478c?db=5)
and also some VBA Script examples here Exporting PowerPoint sections into separate files
PPTalchemy provides some Add-In but unfortunately the code is not available. See here http://www.pptalchemy.co.uk/powerpoint_hints_and_tips_tutorials.html#2010
Moreover it does not suit to move sections easily within the same presentation.
Any idea how to do this?
Many thanks.
Thierry
To move a section within a presentation, including all slides within the section, call this procedure with the index of the section to be moved and it's new location:
Option Explicit
' ********************************************************************************
' VBA Macro for PowerPoint, written by Jamie Garroch of http://YOUpresent.co.uk/
' ********************************************************************************
' Purpose : Moves a specified section of slides to a new section location
' Inputs : lSectionIndex - the index of the section to be moved
' lNewPosition - the index of the position to move to
' Outputs : None.
' ********************************************************************************
Public Sub MoveSection(lSectionIndex As Long, lNewPosition As Long)
On Error GoTo errorhandler
With ActivePresentation
.SectionProperties.Move lSectionIndex, lNewPosition
End With
Exit Sub
errorhandler:
Debug.Print "Couldn't move section due to the following error: " & Err & ", " & Err.Description
End Sub
This is finally the code I use to move multiple sections selected by slides:
Sub MoveSelectedSections()
' Slides are copied ready to be pasted
Dim lngNewPosition As Long
'Debug.Print ""
'Debug.Print "###Move Sections..."
lngNewPosition = InputBox("Enter a destination section index:")
lngNewPosition = CInt(lngNewPosition) ' Convert String to Int
Call MoveSectionsSelectedBySlides(ActivePresentation, lngNewPosition)
End Sub
Function MoveSectionsSelectedBySlides(oPres As Presentation, lNewPosition As Long)
On Error GoTo errorhandler
' Activate input presentation
oPres.Windows(1).Activate
' Get Selected Sections Indexes
' http://www.thespreadsheetguru.com/the-code-vault/2014/4/3/copy-selected-slides-into-new-powerpoint-presentation
Dim i, cnt As Integer
Dim SelectedSlides As SlideRange
Dim SectionIndexes() As Long
If ActiveWindow.Selection.Type <> ppSelectionSlides Then
MsgBox "No slides selected"
Exit Function
End If
Set SelectedSlides = ActiveWindow.Selection.SlideRange
' selection order is reverse see http://www.pptfaq.com/FAQ00869_Create_a_custom_show_from_current_slide_selection_using_VBA.htm
'Fill an array with sectionIndex numbers
ReDim SectionIndexes(1 To SelectedSlides.Count)
cnt = 0
For i = 1 To SelectedSlides.Count
' Check if already present in array
If Not Contains(SectionIndexes, SelectedSlides(i).sectionIndex) Then
cnt = cnt + 1
SectionIndexes(cnt) = SelectedSlides(i).sectionIndex
End If
Next i
ReDim Preserve SectionIndexes(1 To cnt)
' Move Sections to lNewPosition, first last
For i = 1 To cnt
With oPres
.SectionProperties.Move SectionIndexes(i), lNewPosition
End With
Debug.Print "Section #" & SectionIndexes(i) & " moved to " & lNewPosition
Next i
Exit Function
errorhandler:
Debug.Print "Couldn't move section due to the following error: " & Err & ", " & Err.Description
End Function
Function Contains(arr, v) As Boolean
' http://stackoverflow.com/a/18769246/2043349
Dim rv As Boolean, i As Long ' Default value of boolean is False
For i = LBound(arr) To UBound(arr)
If arr(i) = v Then
rv = True
Exit For
End If
Next i
Contains = rv
End Function
i am farly new to VBa and am trying to learn by building or replicating existing vba sheets.
In this one, i am getting an error in the following code:
Private Sub lstLookup_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'declare the variables
Dim cPayroll As String
Dim I As Integer
Dim findvalue
'error block
On Error GoTo errHandler:
'get the select value from the listbox
For I = 0 To lstLookup.ListCount - 1
If lstLookup.Selected(I) = True Then
cPayroll = lstLookup.List(I, 1)
End If
Next I
'find the payroll number
Set findvalue = Sheet2.Range("F:F").Find(What:=cPayroll, LookIn:=xlValues).Offset(0, -3)
'add the database values to the userform
cNum = 21
For X = 1 To cNum
Me.Controls("Reg" & X).Value = findvalue
Set findvalue = findvalue.Offset(0, 1)
Next
'disable adding
Me.cmdAdd.Enabled = False
Me.cmdEdit.Enabled = True
'error block
On Error GoTo 0
Exit Sub
errHandler::
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
It is giving me the error :" 424 Object required"
i cant seem to find the error
Can someone help me?
Thanks in advance.
Change
Me.cmdAdd.Enabled = False
Me.cmdEdit.Enabled = True
to
Me.Controls("cmdAdd").Enabled = False
Me.Controls("cmdEdit").Enabled = True
I'm trying to create a macro in Access 2010 that opens an excel file, runs the macro in excel and then imports the given results. I have 2 problems with this process.
Application.DisplayAlerts = False in Excel
Nevertheless DisplayAlerts keep popping up. Do I need to do something special in the macro Access?
Alert "Can't append due to primary key violations" keeps popping up. I know what the problem is, but I want to ignore it. I can use On Error Resume? But I want a at the end a messagebox with the the table it hasn't append to. Is this possible and can you point me in the right direction. I already tried some errorhandeling but i don't know how to make the message popup at the end without interrupting the process.
code:
Private Sub Main_btn_Click()
Dim fileImport(0 To 3, 0 To 2) As String
fileImport(0, 0) = "Stock_CC"
fileImport(0, 1) = "F:\370\Hyperviseur\SITUATIE\Macro\Stock_getdata.xlsm"
fileImport(0, 2) = "GetStock"
fileImport(1, 0) = "Wips_CC"
fileImport(1, 1) = "F:\370\Hyperviseur\SITUATIE\Macro\Wips_getdata.xlsm"
fileImport(1, 2) = "Update"
fileImport(2, 0) = "CCA_cc"
fileImport(2, 1) = "F:\370\Hyperviseur\SITUATIE\Macro\SLAcc.xls"
fileImport(2, 2) = "Read_CCA"
fileImport(3, 0) = "Eps_cc"
fileImport(3, 1) = "F:\370\Hyperviseur\SITUATIE\Macro\eps.xlsm"
fileImport(3, 2) = "Update"
Dim i As Integer
For i = 0 To UBound(fileImport, 1)
RunMacroInxcel fileImport(i, 1), fileImport(i, 2)
transferSpreadsheetFunction fileImport(i, 0), fileImport(i, 1)
Next i
End Sub
Private Sub RunMacroInExcel(fName As String, macroName As String)
Dim Xl As Object
'Step 1: Start Excel, then open the target workbook.
Set Xl = CreateObject("Excel.Application")
Xl.Workbooks.Open (fName)
Xl.Visible = True
Xl.Run (macroName)
Xl.ActiveWorkbook.Close (True)
Xl.Quit
Set Xl = Nothing
End Sub
Private Sub transferSpreadsheetFunction(ByVal tableName As String, ByVal fileName As String)
If FileExist(fileName) Then
DoCmd.TransferSpreadsheet acImport, , tableName, fileName, True
Else
Dim Msg As String
Msg = "Bestand niet gevonden" & Str(Err.Number) & Err.Source & Err.Description
MsgBox (Msg)
End If
End Sub
Function FileExist(sTestFile As String) As Boolean
Dim lSize As Long
On Error Resume Next
lSize = -1
lSize = FileLen(sTestFile)
If lSize > -1 Then
FileExist = True
Else
FileExist = False
End If
End Function
Add error handling within the For Loop, concatenate to a string variable, then message box the string:
Dim i As integer, failedFiles as string
failedFiles = "List of failed tables: " & vbNewLine & vbNewLine
For i = 0 To UBound(fileImport, 1)
On Error Goto NextFile
Call RunMacroInxcel(fileImport(i, 1), fileImport(i, 2))
Call transferSpreadsheetFunction(fileImport(i, 0), fileImport(i, 1))
NextFile:
failedFiles = failedFiles & " " & fileImport(i,0) & vbNewLine
Resume NextFile2
NextFile2:
Next i
MsgBox failedFiles, vbInformation, "Failed Tables List"
New to vba, trying an 'on error goto' but, I keep getting errors 'index out of range'.
I just want to make a combo box that is populated by the names of worksheets which contain a querytable.
For Each oSheet In ActiveWorkbook.Sheets
On Error GoTo NextSheet:
Set qry = oSheet.ListObjects(1).QueryTable
oCmbBox.AddItem oSheet.Name
NextSheet:
Next oSheet
I'm not sure whether the problem is related to nesting the On Error GoTo inside a loop, or how to avoid using the loop.
The problem is probably that you haven't resumed from the first error. You can't throw an error from within an error handler. You should add in a resume statement, something like the following, so VBA no longer thinks you are inside the error handler:
For Each oSheet In ActiveWorkbook.Sheets
On Error GoTo NextSheet:
Set qry = oSheet.ListObjects(1).QueryTable
oCmbBox.AddItem oSheet.Name
NextSheet:
Resume NextSheet2
NextSheet2:
Next oSheet
As a general way to handle error in a loop like your sample code, I would rather use:
on error resume next
for each...
'do something that might raise an error, then
if err.number <> 0 then
...
end if
next ....
How about:
For Each oSheet In ActiveWorkbook.Sheets
If oSheet.ListObjects.Count > 0 Then
oCmbBox.AddItem oSheet.Name
End If
Next oSheet
Actualy the Gabin Smith's answer needs to be changed a bit to work, because you can't resume with without an error.
Sub MyFunc()
...
For Each oSheet In ActiveWorkbook.Sheets
On Error GoTo errHandler:
Set qry = oSheet.ListObjects(1).QueryTable
oCmbBox.AddItem oSheet.name
...
NextSheet:
Next oSheet
...
Exit Sub
errHandler:
Resume NextSheet
End Sub
There is another way of controlling error handling that works well for loops. Create a string variable called here and use the variable to determine how a single error handler handles the error.
The code template is:
On error goto errhandler
Dim here as String
here = "in loop"
For i = 1 to 20
some code
Next i
afterloop:
here = "after loop"
more code
exitproc:
exit sub
errhandler:
If here = "in loop" Then
resume afterloop
elseif here = "after loop" Then
msgbox "An error has occurred" & err.desc
resume exitproc
End if
I do not want to craft special error handlers for every loop structure in my code so I have a way of finding problem loops using my standard error handler so that I can then write a special error handler for them.
If an error occurs in a loop, I normally want to know about what caused the error rather than just skip over it. To find out about these errors, I write error messages to a log file as many people do. However writing to a log file is dangerous if an error occurs in a loop as the error can be triggered for every time the loop iterates and in my case 80 000 iterations is not uncommon. I have therefore put some code into my error logging function that detects identical errors and skips writing them to the error log.
My standard error handler that is used on every procedure looks like this. It records the error type, procedure the error occurred in and any parameters the procedure received (FileType in this case).
procerr:
Call NewErrorLog(Err.number, Err.Description, "GetOutputFileType", FileType)
Resume exitproc
My error logging function which writes to a table (I am in ms-access) is as follows. It uses static variables to retain the previous values of error data and compare them to current versions. The first error is logged, then the second identical error pushes the application into debug mode if I am the user or if in other user mode, quits the application.
Public Function NewErrorLog(ErrCode As Variant, ErrDesc As Variant, Optional Source As Variant = "", Optional ErrData As Variant = Null) As Boolean
On Error GoTo errLogError
'Records errors from application code
Dim dbs As Database
Dim rst As Recordset
Dim ErrorLogID As Long
Dim StackInfo As String
Dim MustQuit As Boolean
Dim i As Long
Static ErrCodeOld As Long
Static SourceOld As String
Static ErrDataOld As String
'Detects errors that occur in loops and records only the first two.
If Nz(ErrCode, 0) = ErrCodeOld And Nz(Source, "") = SourceOld And Nz(ErrData, "") = ErrDataOld Then
NewErrorLog = True
MsgBox "Error has occured in a loop: " & Nz(ErrCode, 0) & Space(1) & Nz(ErrDesc, "") & ": " & Nz(Source, "") & "[" & Nz(ErrData, "") & "]", vbExclamation, Appname
If Not gDeveloping Then 'Allow debugging
Stop
Exit Function
Else
ErrDesc = "[loop]" & Nz(ErrDesc, "") 'Flag this error as coming from a loop
MsgBox "Error has been logged, now Quiting", vbInformation, Appname
MustQuit = True 'will Quit after error has been logged
End If
Else
'Save current values to static variables
ErrCodeOld = Nz(ErrCode, 0)
SourceOld = Nz(Source, "")
ErrDataOld = Nz(ErrData, "")
End If
'From FMS tools pushstack/popstack - tells me the names of the calling procedures
For i = 1 To UBound(mCallStack)
If Len(mCallStack(i)) > 0 Then StackInfo = StackInfo & "\" & mCallStack(i)
Next
'Open error table
Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset("tbl_ErrLog", dbOpenTable)
'Write the error to the error table
With rst
.AddNew
!ErrSource = Source
!ErrTime = Now()
!ErrCode = ErrCode
!ErrDesc = ErrDesc
!ErrData = ErrData
!StackTrace = StackInfo
.Update
.BookMark = .LastModified
ErrorLogID = !ErrLogID
End With
rst.Close: Set rst = Nothing
dbs.Close: Set dbs = Nothing
DoCmd.Hourglass False
DoCmd.Echo True
DoEvents
If MustQuit = True Then DoCmd.Quit
exitLogError:
Exit Function
errLogError:
MsgBox "An error occured whilst logging the details of another error " & vbNewLine & _
"Send details to Developer: " & Err.number & ", " & Err.Description, vbCritical, "Please e-mail this message to developer"
Resume exitLogError
End Function
Note that an error logger has to be the most bullet proofed function in your application as the application cannot gracefully handle errors in the error logger. For this reason, I use NZ() to make sure that nulls cannot sneak in. Note that I also add [loop] to the second identical error so that I know to look in the loops in the error procedure first.
What about?
If oSheet.QueryTables.Count > 0 Then
oCmbBox.AddItem oSheet.Name
End If
Or
If oSheet.ListObjects.Count > 0 Then
'// Source type 3 = xlSrcQuery
If oSheet.ListObjects(1).SourceType = 3 Then
oCmbBox.AddItem oSheet.Name
End IF
End IF