Access VBA: Discard "can't append" message (Primary Key Violation) - vba

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"

Related

Code error - Saving CSV file asking to overwrite

My code gives me error from
If Dir(Pth, vbArchive) <> vbNullString Then
I havent been able to find the error - Can someone help me what is wrong with the code? Is it supposed to say USERPROFILE, or am i supposed to write something else?
Sub Opgave8()
Dim sh As Worksheet
Dim Pth As String
Application.ScreenUpdating = False
' Create default desktop path using windows user id
user_id = Environ$("USERPROFILE")
' Create full path
file_name$ = "\AdminExport.csv"
Pth = Environ$("USERPROFILE") & "\Desktop\" & FileName
Set sh = Sheets.Add
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
sh.Cells(i, 2) = Worksheets("Base").Cells(i, 4)
End If
Next i
sh.Move
If Dir(Pth, vbArchive) <> vbNullString Then
overwrite_question = MsgBox("File already exist, do you want to overwrite it?", vbYesNo)
End If
If overwrite_question = vbYes Then
With ActiveWorkbook
.SaveAs FileName:=Pth, FileFormat:=xlCSV
.Close False
End With
End If
Application.ScreenUpdating = True
End Sub
Function UniqueRandDigits(x As Long) As String
Dim i As Long
Dim n As Integer
Dim s As String
Do
n = Int(Rnd() * 10)
If InStr(s, n) = 0 Then
s = s & n
i = i + 1
End If
Loop Until i = x + 1
UniqueRandDigits = s
End Function
There are a few issues in your code. I don't understand why you are getting an error message, but if you fix your issues, you are in a better position of finding the main problem.
Put Option Explicit at the top. If you do that, you will not do mistakes like setting the variable file_name$ but reading from the variable FileName.
You are building a path with double backslashes. Perhaps not a big thing and it'll probably work. Add a Debug.Print Pth just before your troublesome If. Press Ctrl-G to show the debug pane and study the output. Does the printed file path exist?
Don't use vbNullString. Test with abc <> "" instead.

Error 424 Object needed - Cant seem to find the error

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

VBA won't call UserForm from inside its own workbook

I have a CMD button on my sheet with the following code:
Private Sub cmdBlastoff_Click()
UserForm2.Show vbModeless 'launch gateway userform
End Sub
This code worked for a long time, but is now generating "Error 9: Subscript out of range."
The userform I am trying to call (UserForm2) is located in the same workbook.
I will put the full code of the userform below in case it's relevant, but the code in its Userform_initialize sub is:
Private Sub userform_initialize()
Sheets("hiddensheet1").Range("B5").Value = "v7.04" 'sets version # in hidden sheet
FileNameChecker_local 'runs a sub (located below in the userform module) to determine the filename and path
ValueInjector 'runs a sub (located below in the userform module) to put some values into text fields on the userform
cmdBigGo.Font.Size = 15 'sets font size of a button
End Sub
As I said earlier, this was working until recently and I am out of ideas.
So far I have tried:
1) Finding some way to explicitly point to the exact location of
userform2 by specifying the workbook in front of it:
ActiveWorkbook.UserForm2.show (doesn't work for reasons that are
now obvious) I regard a more explicit call as the most likely fix,
but don't know how to do it
2) Removing vbModeless from the call button call
3) Explicitly setting the ActiveWorkbook to the one all my stuff is
stored on, which is where the call button sits (this shouldn't be
necessary, I know)
Any other ideas?
Full code of the UserForm2 (probably not relevant, all working prior to this problem arising):
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
'should check to see if there is an output folder in the directory where COGENT sits and if not create it
'should pull default filepath to the outputs folder from the hiddensheet
'should call data baster on terminate
'DONE should allow the user to change the default save location
'DONE should allow them to change the save location THIS time.
'DONE should pull filepath from hiddensheet, check against original (?) and
'DONE Should create a default filename
Public strFileFullName As String
Public strFileJustPath As String
Public strUserFolderName As String
Public strFileName As String
Public strRawDate As String
Public strDLlink As String
Public strDLdest As String
Public strDLlocalName As String
Public strDLNameOnWeb As String
Public strOpenURLPointer As String
Dim strSaveAsErrHandler As String
Dim strQueryID As String
Private Sub userform_initialize()
Sheets("hiddensheet1").Range("B5").Value = "v7.04" 'sets version # in hidden sheet
FileNameChecker_local 'runs a sub (located below in the userform module) to determine the filename and path
ValueInjector 'runs a sub (located below in the userform module) to put some values into text fields on the userform
cmdBigGo.Font.Size = 15 'sets font size of a button
End Sub
Private Sub chkCyberDiv_Click()
If chkCyberDiv.Value = True Then
'==Cyber OUs visible==
chkNDIO.Visible = True
txtQueryID.Value = "169436"
'==Other Div OUs invisible==
chkCivilDiv.Value = False
Else
chkNDIO.Visible = False
End If
End Sub
Private Sub chkCivilDiv_Click()
If chkCivilDiv.Value = True Then
'==Civil OUs visible==
chkCivilInfoSys.Visible = True
'==Other Div OUs invisible==
chkCyberDiv.Value = False
Else
chkCivilInfoSys.Visible = False
End If
End Sub
Sub cmdBigGo_Click()
'==========Check if SaveAsNewName worked and if not kill sub==========
SaveAsNewName
If strSaveAsErrHandler = "Filename/path not viable." Then
MsgBox strSaveAsErrHandler
Exit Sub
Else
'==========Startup==========
Application.ScreenUpdating = False
Sheets("LoadingData").Visible = True
Sheets("Launchpad").Visible = False
'==========Check for/create Temp Directory==========
If FileFolderExists(strFileJustPath & "\temp") = True Then
'MsgBox "temp Folder already exists."
Else
MkDir strFileJustPath & "\temp"
'MsgBox "temp Folder didn't exist, but it do now."
End If
'==========Download Section==========
'=====Set up===== 'big gap for now = 169436
strQueryID = txtQueryID.Value
strDLlink = "https://workbench.northgrum.com/xauth/login.aspx?&ActionPageID=37&ActionParameters=QueryID%3d" & strQueryID & "%26View%3d0%26OutputToExcel%3d1"
strDLdest = strFileJustPath & "\temp\dump.xlsx"
'=====Run=====
'MsgBox "cmdBigGo thinks strDLdest = " & strDLdest
Dim done
done = URLDownloadToFile(0, strDLlink, strDLdest, 0, 0)
'==========Copy Targets from temp file==========
Sheets("LoadingData").Select
copyPathName = strFileJustPath & "\temp\"
copyFileName = "dump.xlsx"
copyTabName = "Targets"
ControlFile = ActiveWorkbook.Name
Workbooks.Open FileName:=copyPathName & "\" & copyFileName
ActiveSheet.Name = copyTabName
Sheets(copyTabName).Copy After:=Workbooks(ControlFile).Sheets(1)
Windows(copyFileName).Activate
ActiveWorkbook.Close SaveChanges:=False
Windows(ControlFile).Activate
ActiveWorkbook.Sheets("Targets").Name = "COGENT Targets"
'^source: https://msdn.microsoft.com/en-us/library/office/ff194819.aspx
'==========Delete Temp Directory==========
On Error Resume Next
Kill copyPathName & "\*.*" ' delete all files in the folder
RmDir copyPathName ' delete folder
On Error GoTo 0
'==========Create Userform1 Button on "Targets"==========
Rows("1:1").RowHeight = 26
Dim btnCOGENT As Button
Set btnCOGENT = Sheets("COGENT Targets").Buttons.Add(10.5, 4.5, 84.75, 19.5)
With btnCOGENT
.OnAction = "CallUserform1"
.Characters.Text = "COGENT"
End With
With btnCOGENT.Characters(Start:=1, Length:=6).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
Sheets("COGENT Targets").Shapes("Button 1").ScaleWidth 0.7433628319, msoFalse, _
msoScaleFromTopLeft
'==========Finish up==========
Worksheets("COGENT Targets").Activate
Sheets("LoadingData").Visible = False
Application.ScreenUpdating = True
End If
UserForm1.Show vbModeless
End Sub
Private Sub SaveAsNewName()
strSaveAsErrHandler = ""
On Error GoTo ErrorHandler
'==========Save the file with a new name==========
Dim strExpectedFileFullName As String
strExpectedFileFullName = txtFilePath.Value & "\" & txtFileName & ".xlsm"
ActiveWorkbook.SaveAs strExpectedFileFullName
FileNameChecker_local 'get the new filename
Exit Sub
ErrorHandler:
'==========Error Handler==========
If Err.Number = 1004 Then
lblSaveAsText.Caption = "That name and location didn't work... Try using 'Browse' or 'Create Outbox."
lblSaveAsText.BackColor = &H8080FF
strSaveAsErrHandler = "Filename/path not viable."
Else
MsgBox "unknown error...email Owen.Britton#NGC.com; it's probably his fault."
strSaveAsErrHandler = ""
End If
End Sub
Sub FileNameChecker_local()
'==========Check Filename and SaveAs if needed==========
strFileJustPath = ActiveWorkbook.Path
strFileFullName = ActiveWorkbook.FullName
'==========Get Filename==========
Dim i As Integer
Dim intBackSlash As Integer, intPoint As Integer
For i = Len(strFileFullName) To 1 Step -1
If Mid$(strFileFullName, i, 1) = "." Then
intPoint = i
Exit For
End If
Next i
If intPoint = 0 Then intPoint = Len(strFileFullName) + 1
For i = intPoint - 1 To 1 Step -1
If Mid$(strFileFullName, i, 1) = "\" Then
intBackSlash = i
Exit For
End If
Next i
strFileName = Mid$(strFileFullName, intBackSlash + 1, intPoint - intBackSlash - 1)
'MsgBox "strFileName = " & strFileName & vbNewLine & _
"strFileJustPath = " & strFileJustPath & vbNewLine & _
"strFileFullName = " & strFileFullName & vbNewLine & _
"ran from userform2"
End Sub
Private Sub ValueInjector()
strRawDate = Format(Date, "mm-d-yy")
'==========Inject File Name==========
If strFileName = "COGENT Launchpad" Then
txtFileName.Value = "COGENT_Pull_" & strRawDate 'might be better to include query number\
lblSaveAsText.Caption = "Give your output a descriptive name. Here's a suggestion:"
Else
'txtFileName.Value = strFileName
lblSaveAsText.Caption = "This file should be named 'COGENT Launchpad.' Some features break if you rename it."
lblSaveAsText.BackColor = &H8080FF
'MsgBox "Please rename this file 'COGENT Launchpad'"
End If
'==========Inject File Path==========
Application.ScreenUpdating = False
If IsEmpty(Worksheets("Hiddensheet1").Range("B6")) Then
cmdCreateOutbox_click
Worksheets("Hiddensheet1").Range("B6") = strFileJustPath & "\Outbox"
txtFilePath.Value = Worksheets("Hiddensheet1").Range("B6")
Else
txtFilePath.Value = Worksheets("Hiddensheet1").Range("B6")
End If
Application.ScreenUpdating = True
Worksheets("Launchpad").Activate
End Sub
Private Sub cmdBrowse_Click()
FileNameChecker_local
GetFolder (strFileJustPath)
End Sub
Private Sub cmdMakeDefault_Click()
Worksheets("Hiddensheet1").Range("B6") = txtFilePath.Value
imgCheckMark.Visible = True
End Sub
Private Sub cmdCreateOutbox_click()
'MsgBox "looking for" & strFileJustPath & "\Outbox"
If FileFolderExists(strFileJustPath & "\Outbox") Then
MsgBox "Outbox Folder already exists."
Else
MsgBox "Outbox Folder did not exist, but it does now."
MkDir strFileJustPath & "\Outbox"
txtFilePath.Value = strFileJustPath & "\Outbox"
End If
End Sub
Function GetFolder(strFilePath As String) As String
Dim fldr As FileDialog
Dim strGetFolderOutput As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strFilePath
If .Show <> -1 Then GoTo NextCode
strGetFolderOutput = .SelectedItems(1)
End With
NextCode:
GetFolder = strGetFolderOutput
txtFilePath.Value = strGetFolderOutput
Set fldr = Nothing
End Function
Private Sub userform_terminate()
Unload Me
End Sub
Somehow the hidden sheet got deleted, and it gets referred to before I check its existence and create it if missing. Thanks guys; I was barking up totally the wrong tree. Fixed and working.
Nothing was wrong with the calling of the userform at all.

VB - Subscript out of range, error 9

**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.

Entering Dates Without Slashes

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