- Joined
- Jul 9, 2011
- Messages
- 4
- Reaction score
- 0
I have added code to a macro and it is creating this error but I am not sure why.
Below is the line it errors out on
This is the new code I added to deal with a formatting issue when importing an excel file
*edit: I have determined this is creating the issue but I am not sure why...
This is the full code if it will help:
If you just want to suggest improvements to the code that would be awesome too as I am self taught and realize there is probably a vast amount of dumb stuff going on... thx
Below is the line it errors out on
Code:
Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , strPassword)This is the new code I added to deal with a formatting issue when importing an excel file
*edit: I have determined this is creating the issue but I am not sure why...
Code:
' earlstaley 4/21/2013
' Format HOCustID as text
' Set xl = CreateObject("Excel.Application")
' 'xl.Visible = True
' xl.DisplayAlerts = False
' Set wbk = xl.Workbooks.Open(strPathFile)
' Set wsht = wbk.Worksheets(1)
'
' wsht.Columns("E:E").NumberFormat = "@"
'
' Set wsht = Nothing
' wbk.Save
' wbk.Close
' Set wbk = Nothing
' xl.Quit
' Set xl = NothingThis is the full code if it will help:
Code:
Private Sub cmdSelect_Click()
Dim blnHeader As Boolean
Dim blnExcel As Boolean
Dim blnReadOnly As Boolean
Dim lngCount As Long
Dim objExcel As Object
Dim xl As Object 'New
Dim wbk As Object 'New
Dim wsht As Object 'New
Dim objWorkbook As Object
Dim colWorksheets As Collection
Dim strPathFile As String
Dim strFileSel As String
Dim strPassword As String
Dim strSql As String
Dim strMstTbl As String
Dim strTmpTbl As String
Dim strQryUpdTmp As String
Dim strQryFileName As String
Dim strQryFileURL As String
Dim strDate As String
Dim strSiteYear As String
Dim strSiteMonth As String
Dim strSite As String
Dim strFileRef As String
Dim strFileName As String
Dim strUser As String
Dim strCompanyRef As String
Dim rsFileURL As DAO.Recordset
Dim rsImported As DAO.Recordset
Dim db As DAO.Database
Dim frm As Form
''''''''''''''''''''''''''''''''''''''''''
' Check file was selected
If Me!listFiles.ListIndex = "-1" Then
MsgBox "Please select a file from the list.", vbCritical, "File Selection Required"
Me!listFiles.SetFocus
Exit Sub
End If
''''''''''''''''''''''''''''''''''''''''''
' File path
strFileSel = Me!listFiles.Value
strQryFileURL = "SELECT tbl_Files.* FROM tbl_Files WHERE tbl_Files.FName = '" & strFileSel & "'"
Set db = Access.CurrentDb
Set rsFileURL = db.OpenRecordset(strQryFileURL, dbOpenDynaset)
strFileName = rsFileURL.Fields("FURL")
Set rsFileName = Nothing
Set db = Nothing
''''''''''''''''''''''''''''''''''''''''''
' Master Table
strMstTbl = "tbl_LS_mst"
' Temporary Table
strTmpTbl = "tbl_LS_tmp"
' Site address
strSite = "some website dot com"
' File date
strDate = Format(Date, "YYYYMMDD")
'CompanyRef Date
strCompanyRef = Format(Now(), "YYYYMMDDHHMMSS")
' Username
strUser = (Environ$("Username"))
' Master file ref number
strFileRef = Format(Now(), "YYYYMMDD|HH:MM:SS") & "|" & strUser
' File location
strPathFile = strFileName
''''''''''''''''''''''''''''''''''''''''''
' Update temp table query
strQryUpdTmp = "UPDATE " & strTmpTbl & _
" SET " & strTmpTbl & ".ImportBatchRef = '" & strFileRef & "', " & strTmpTbl & ".FileName = '" & strFileSel & _
"', " & strTmpTbl & ".EntityState = [Entity] & [State], " & strTmpTbl & _
".EntityStateCust = [Entity] & [State] & [CustomerGroup], " & strTmpTbl & _
".StateCust = [State] & [CustomerGroup]"
''''''''''''''''''''''''''''''''''''''''''
' Delete all records from tmp table
DoCmd.SetWarnings False
DoCmd.RunSQL ("DELETE * FROM " & strTmpTbl)
' earlstaley 4/21/2013
' Format HOCustID as text
' Set xl = CreateObject("Excel.Application")
' 'xl.Visible = True
' xl.DisplayAlerts = False
' Set wbk = xl.Workbooks.Open(strPathFile)
' Set wsht = wbk.Worksheets(1)
'
' wsht.Columns("E:E").NumberFormat = "@"
'
' Set wsht = Nothing
' wbk.Save
' wbk.Close
' Set wbk = Nothing
' xl.Quit
' Set xl = Nothing
' Establish an Excel application object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set objExcel = CreateObject("Excel.Application")
blnExcel = True
End If
Err.Clear
On Error GoTo 0
' The first row in the worksheet has field names
blnHeader = True
' Password
strPassword = vbNullString
' Open Excel file in read-only mode
blnReadOnly = True
' Open the Excel file and read the worksheet names into a collection
Set colWorksheets = New Collection
Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , strPassword)
'For lngCount = 1 To objWorkbook.Worksheets.Count
lngCount = 1
colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
'Next lngCount
' Close the Excel file
objWorkbook.Close False
Set objWorkbook = Nothing
If blnExcel = True Then objExcel.Quit
Set objExcel = Nothing
' Import the data from each worksheet into a temporary table
'For lngCount = colWorksheets.Count To 1 Step -1
For lngCount = 1 To 1
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, strTmpTbl, strPathFile, blnHeader, "A:P"
Next lngCount
' Delete the collection
Set colWorksheets = Nothing
'Add unique reference for each record
DoCmd.RunSQL ("ALTER TABLE tbl_LS_tmp ADD Reference COUNTER")
DoCmd.RunSQL ("UPDATE " & strTmpTbl & " SET " & strTmpTbl & ".DHGReference = [Entity] & '-' & " & strDHGRef & " & '-' & [Reference]")
CurrentDb.TableDefs(strTmpTbl).Fields.Delete "Reference"
' Update file name, and batch ref in temporary table
DoCmd.RunSQL (strQryUpdTmp)
''''''''''''''''''''''''''''''''''''''''
' TaxGroup Check '
''''''''''''''''''''''''''''''''''''''''
Set rTG = CurrentDb.OpenRecordset("SELECT tbl_LS_tmp.TaxGroup FROM tbl_LS_tmp WHERE (Exists (SELECT NULL FROM tbl_SKU_Mapping WHERE tbl_SKU_Mapping.TaxGroup = tbl_LS_tmp.TaxGroup)=False)")
If (rTG.EOF And rTG.BOF) Then GoTo Import:
Set rTG = Nothing
DoCmd.RunSQL ("DELETE * FROM " & strTmpTbl)
DoCmd.SetWarnings True
MsgBox "File contains unmapped TaxGroup(s). File not imported."
Exit Sub
''''''''''''''''''''''''''''''''''''''''
Import:
' Append temp table to master
DoCmd.RunSQL ("INSERT INTO " & strMstTbl & " SELECT " & strTmpTbl & ".* FROM " & strTmpTbl)
' Update tbl_ImportedFiles
Set db = Access.CurrentDb
With db.OpenRecordset("tbl_ImportedFiles")
.AddNew
!FileName = strFileSel
!ImportedBatchRef = strFileRef
.Update
End With
Set db = Nothing
DoCmd.RunSQL ("DELETE * FROM " & strTmpTbl)
Set frm = Forms("frm_AvailFiles")
frm.listFiles.Requery
Set frm = Nothing
MsgBox ("File imported successfully.")
Error:
DoCmd.SetWarnings True
Set frm = Forms("frm_AvailFiles")
frm.listFiles.Requery
Set frm = Nothing
End SubIf you just want to suggest improvements to the code that would be awesome too as I am self taught and realize there is probably a vast amount of dumb stuff going on... thx
Last edited: