**I am new to VB and I received and error 9, subscript out of range. The error indicated it was in the below procedure. Please let me know what might be the issue. I appreciate your assistance
Private Sub RebuildGrid()
Const c_strProcedureName As String = "RebuildGrid"
Dim intIndex As Integer
On Error GoTo Error_Handler
For intIndex = 0 To g_intNumNucDataFields - 1
grdNuclides.Columns(intIndex).DataField = ga_strNucFieldName(intIndex)
grdNuclides.Columns(intIndex).Visible = False
If StrComp(ga_strNucFieldFormat(intIndex), "None", vbTextCompare) <> 0 Then
grdNuclides.Columns(intIndex).NumberFormat = ga_strNucFieldFormat(intIndex)
End If
grdNuclides.Columns(intIndex).Width = 1400
If StrComp(LCase$(ga_strNucFieldUnits(intIndex)), "none", vbTextCompare) = 0 Then
grdNuclides.Columns(intIndex).Caption = ga_strNucFieldTitle(intIndex)
Else
grdNuclides.Columns(intIndex).Caption = ga_strNucFieldTitle(intIndex) & _
" " & vbCr & "(" & ga_strNucFieldUnits(intIndex) & ") "
End If
grdNuclides.Columns(intIndex).FooterText = "Reference"
Next intIndex
Exit Sub
Error_Handler:
gud_PrgErr.Number = Err.Number
gud_PrgErr.Severity = 5
gud_PrgErr.Description = Err.Description
gud_PrgErr.Module = c_strModuleName
gud_PrgErr.Procedure = c_strProcedureName
Call Display_UI_Error
End Sub
Private Sub mnuFileExit_Click()
Unload Me
End Sub
Make sure g_intNumNucDataFields is not higher than the number of columns (eg grdNuclides.Columns.Count).
You could also try commenting out the error handling and then running it to see if you get a line number on the error.
Related
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
I have this code that check if the attachment size of the attachment is greater than 10MB. Now, if the attachment is greater than 10MB, it displays the file names on a msgbox then I want to select or highlight the cells that has this attachment greater than 10 MB but dunno how to do it.
Here's what I've tried:
Function checkAttSize()
Application.ScreenUpdating = False
Dim attach As Object
Dim attSize() As String
Dim loc() As String
Dim num As Long
Dim rng As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Set main = ThisWorkbook.Sheets("Main")
lRow = Cells(Rows.count, 15).End(xlUp).Row
efCount = 0
num = 0
With objMail
If lRow > 22 Then
On Error GoTo errHandler
For i = 23 To lRow
'attach.Add main.Range("O" & i).value
'totalSize = totalSize +
If (FileLen(main.Cells(i, "O").value) / 1000000) > 10 Then
ReDim Preserve attSize(efCount)
ReDim Preserve loc(num)
'store file names
attSize(efCount) = Dir(main.Range("O" & i))
'store cell address
loc(num) = i
efCount = efCount + 1
num = num + 1
found = True
End If
Next i
End If
End With
If found = True Then
MsgBox "Following File(s) Exceeds 10MB Attachment Size Limit:" & vbCrLf & vbCrLf & Join(attSize, vbCrLf) _
& vbCrLf & vbCrLf & "Please try removing the file(s) and try again.", vbCritical, "File Size Exceed"
'trying to select the cell addresses
For i = 1 To num
rng = rng + main.Range("O" & loc(i)).Select ' Ive also tried &
Next i
checkAttSize = True
Exit Function
End If
Exit Function
errHandler:
MsgBox "Unexpected Error Occured.", vbCritical, "Error"
checkAttSize = True
End Function
Thanks for the help.
No need to select the range. A single miss click by the user take take the focus away from the range. Also using .Select recklessly may cause run time errors. Color them instead.
After this line
If (FileLen(main.Cells(i, "O").value) / 1000000) > 10 Then
Add this line
main.Cells(i, "O").Interior.ColorIndex = 3
The cells now will be colored in red.
And in the end, alert the user with the message
If found = True Then
MsgBox "File(s) Exceeding 10MB Attachment Size Limit has been colored in red:"
End If
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"
I sometimes have to enter a lot of dates in Excel spreadsheets. Having to enter the slashes slows things down a lot and makes the process more error prone. On many database programs, it is possible to enter the dates using only the numbers.
I have written a SheetChange event handler that lets me do this when entering dates in cells formatted as dates, but it fails if I copy a date from one location to another. If I could determine when an entry has been copied as opposed to entered, I could handle the two cases separately, but I have not been able to determine this yet.
Here is my code, but before you look at it, be aware that the last section handles inserting a decimal point automatically and it seems to be working ok. Finally, I added some variables (sValue, sValue2, etc.) to make it a little easier for me to track the data.
Option Explicit
Private WithEvents App As Application
Private Sub Class_Initialize()
Set App = Application
End Sub
Private Sub App_SheetChange(ByVal Sh As Object, ByVal Source As Range)
Dim s As String
Dim sFormat As String
Dim sValue As String
Dim sValue2 As String
Dim sFormula As String
Dim sText As String
Dim iPos As Integer
Dim sDate As String
On Error GoTo ErrHandler:
If Source.Cells.Count > 1 Then
Exit Sub
End If
If InStr(Source.Formula, "=") > 0 Then
Exit Sub
End If
sFormat = Source.NumberFormat
sFormula = Source.Formula
sText = Source.Text
sValue2 = Source.Value2
sValue = Source.Value
iPos = InStr(sFormat, ";")
If iPos > 0 Then sFormat = Left(sFormat, iPos - 1)
If InStr("m/d/yy|m/d/yyyy|mm/dd/yy|mm/dd/yyyy|mm/dd/yy", sFormat) > 0 Then
If IsDate(Source.Value2) Then
Exit Sub
End If
If IsNumeric(Source.Value2) Then
s = CStr(Source.Value2)
If Len(s) = 5 Then s = "0" & s
If Len(s) = 6 Then
s = Left(s, 2) & "/" & Mid(s, 3, 2) & "/" & Right(s, 2)
App.EnableEvents = False
If IsDate(s) Then Source.Value = s 'else source is unchanged
App.EnableEvents = True
End If
If Len(s) = 7 Then s = "0" & s
If Len(s) = 8 Then
s = Left(s, 2) & "/" & Mid(s, 3, 2) & "/" & Right(s, 4)
App.EnableEvents = False
If IsDate(s) Then Source.Value = s 'else source is unchanged
App.EnableEvents = True
End If
End If
End If
If InStr(sFormat, "0.00") > 0 Then
If IsNumeric(Source.Formula) Then
s = Source.Formula
If InStr(".", s) = 0 Then
s = Left(s, Len(s) - 2) & "." & Right(s, 2)
App.EnableEvents = False
Source.Formula = CDbl(s)
App.EnableEvents = True
End If
End If
End If
ErrHandler:
App.EnableEvents = True
End Sub
Do you know how I can get this to work for copied dates as well as edited dates? Thanks for your help.
Actually, the event Worksheet_Change is called when copy/pasting, so it should work.
Just tested with:
Private Sub Worksheet_Change(ByVal Target As Range)
MsgBox "Test"
End Sub