Prevent Truncating of Leading Zeros in MS Access vba Import - ms-access

I used the code below to import CSV files from a local folder then into a table in Access.
However, I noticed the Leading Zeros are missing/truncated.
Not sure why as I was under the impression that Access did not cut off the zeros.
I tried padding with zeros but not working. I am thinking the leading zeros are being truncated during import into access and since this is happening by code, not sure how to stop it.
Hopefully the great pros here can take a look:
Option Compare Database
Option Explicit
Sub ImportFileProcedure()
Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
Dim xlApp As Object, xlWb As Object, xlWs As Object
Dim lngRow As Long, lngLastRow As Long
Dim rst As DAO.Recordset
strPath = "C:\FOLDER\"
strTable = "TEMP_TBL"
strFile = Dir(strPath & "*.csv")
Set rst = CurrentDb.OpenRecordset(strTable)
Do While Len(strFile) > 0
strPathFile = strPath & strFile
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open(strPathFile)
Set xlWs = xlWb.Worksheets(1)
lngLastRow = xlWs.UsedRange.Rows.Count
For lngRow = 2 To lngLastRow
rst.AddNew
rst("SAMPLE") = xlWs.Range("A" & lngRow).Value
rst("SAMPLE") = xlWs.Range("B" & lngRow).Value
rst("SAMPLE") = xlWs.Range("C" & lngRow).Value
rst("SAMPLE") = xlWs.Range("D" & lngRow).Value
rst("SAMPLE") = xlWs.Range("E" & lngRow).Value
rst.Update
Next
xlApp.Quit
Set xlApp = Nothing
Set xlWb = Nothing
Set xlWs = Nothing
strFile = Dir()
Loop
rst.Close
Set rst = Nothing
End Sub
Thanks for looking

I decided to simply create an UPDATE query that adds/pads the leading zeros, the UPDATE is run after the data becomes loaded into the table. This was the best I could do rather than modifying the above code:
This is SQL for the UPDATE Query:
x = left(yourfield & string(8,"0"), 8)
x = right(string(8,"0")& yourfield, 8)
or...
padlen = 8
x = left(yourfield & string(padlen,"0"), padlen)
x = right(string(padlen,"0")& yourfield, padlen)
Thanks everyone!

Related

Method Range of _Global object failed

I get a Method Range of Object _Global failed error due to the following code
SOMETIMES this code works SOMETIMES it doesnt. I understand the cause of it but not how to fix it. How do i specify which sheet this is selecting everytime so that it works consistently.
'Fill Formulas'
Range(columnLetter & "5").Select
Selection.AutoFill Destination:=Range(columnLetter & "5:" & columnLetter & "113"), Type:=xlFillDefault
Range(columnLetter & "143").Select
Selection.AutoFill Destination:=Range(columnLetter & "143:" & columnLetter & "251"), Type:=xlFillDefault
Here is all of my code
Public Sub AutoUpdateCancels()
Dim MySheetPath As String
Dim Xl As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim formattedDate As String
Dim lngRow As Long, intCol As Integer, db As DAO.Database, rst As DAO.Recordset, fld As DAO.Field
Dim columnLetter As String
Dim qdf As DAO.QueryDef
columnLetter = DLookup("[Column]", "[tblColumnIdentifier17]", "[WED] like #" & [Forms]![frmCancelsReporting]![txtCancelsWED] & "#")
formattedDate = Format(Date, "mm-dd-yyyy")
MySheetPath = "M:\Chris\Weekly Pulse\Cancel Report\2018\COM\Cancels Report - 2018v2.xlsx"
'Open Excel and the workbook and save a backup
Set Xl = CreateObject("Excel.Application")
Set XlBook = Xl.Workbooks.Open(MySheetPath, True)
Xl.Visible = True
XlBook.Windows(1).Visible = True
Set XlSheet = XlBook.Worksheets(11)
'Xl.ActiveWorkbook.SaveAs FileName:="M:\Chris\Weekly Pulse\Cancel Report\Backups\COM Backup 03-12-2018.xlsx"
'Clear Detail'
Xl.Range("A256:D371").Select
Xl.Selection.ClearContents
'Starting Row Number'
lngRow = 256
'Append New Detail'
Set db = CurrentDb
Set qdf = db.QueryDefs("qryCancelsReport")
qdf.Parameters("EndDate").Value = [Forms]![frmCancelsReporting]![txtCancelsWED]
Set rst = qdf.OpenRecordset()
Xl.Cells(lngRow, 1).CopyFromRecordset rst
'Fill Formulas'
Range(columnLetter & "5").Select
Selection.AutoFill Destination:=Range(columnLetter & "5:" & columnLetter & "113"), Type:=xlFillDefault
Range(columnLetter & "143").Select
Selection.AutoFill Destination:=Range(columnLetter & "143:" & columnLetter & "251"), Type:=xlFillDefault
Set rst = Nothing
Set db = Nothing
Set Xl = Nothing
Set XlBook = Nothing
Set XlSheet = Nothing
MsgBox ("Make sure to save over original worksheet not as backup")
End Sub
You were not referencing proper objects (e.g.: you used Xl.Range() instead of xlSheet.Range())
Avoid using Select/Selection/Activate/ActiveXXX coding pattern an use fully qualified range references (e.g. use xlSheet.Range() instead of Range())
So try this snippet:
With XlBook.Worksheets(11) ‘reference wanted sheet. From now on and till next ‘End With’ all referenced sheet members (like its Range()) are just a dot (.) away:
'Clear Detail'
.Range("A256:D371").ClearContents
'Starting Row Number'
lngRow = 256
'Append New
....
.Cells(lngRow, 1).CopyFromRecordset rst
'Fill Formulas'
.Range(columnLetter & "5").AutoFill Destination:=.Range(columnLetter & "5:" & columnLetter & "113"), Type:=xlFillDefault
.Range(columnLetter & "143").AutoFill Destination:=.Range(columnLetter & "143:" & columnLetter & "251"), Type:=xlFillDefault
End With

How do I automate folder location and file name in Access VBA?

I want to substitute the hard codes between the 2 underlined area in VB as indicated, so that it fetches the excel file automatically with code and transfers the spreadsheet into an Ms-Access table with same fields. IT should be able to do this function automatically with vb codes in MS-Access.
Dim fso As Object 'FileSystemObject
Dim f As Object 'File
Dim strTempPath As String
Dim objExcel As Object 'Excel.Application
Dim objWorkbook As Object 'Excel.Workbook
Const TemporaryFolder = 2
On Error Resume Next
StrSQL = "DELETE * FROM bed_code_tbl"
DoCmd.SetWarnings False
DoCmd.RunSQL StrSQL
Set fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject
strTempPath = fso.GetSpecialFolder(TemporaryFolder) & "\" & fso.GetTempName & "\"
fso.CreateFolder strTempPath
'------------------------------------------------------
Set f = fso.GetFile("C:\Users\johnpfe\Documents\Bed_code_tbl.xlsx")
fso.CopyFile f.Path, strTempPath & f.Name
'--------------------------------------------------------
Set objExcel = CreateObject("Excel.Application") ' New Excel.Application
Set objWorkbook = objExcel.Workbooks.Open(strTempPath & f.Name)
objWorkbook.ActiveSheet.Range("A1:C100").Select
objWorkbook.Save
Set objWorkbook = Nothing
objExcel.Quit
Set objExcel = Nothing
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "bed_code_tbl",
strTempPath & f.Name, True
fso.DeleteFile strTempPath & f.Name
fso.DeleteFolder Left(strTempPath, Len(strTempPath) - 1)
Set f = Nothing
Set fso = Nothing
End Sub
'----------------------------------------------------------------------
I'm assuming that you're trying to find the current user's documents folder.
You can use the eviron() function. More on that if you follow these links.
http://msdn.microsoft.com/en-us/library/office/gg264486(v=office.15).aspx
http://www.tek-tips.com/faqs.cfm?fid=4296
Dim fso As Object 'FileSystemObject
Dim f As Object 'File
Dim strTempPath As String
Dim objExcel As Object 'Excel.Application
Dim objWorkbook As Object 'Excel.Workbook
Const TemporaryFolder = 2
On Error Resume Next
strSQL = "DELETE * FROM bed_code_tbl"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
Set fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject
strTempPath = fso.GetSpecialFolder(TemporaryFolder) & "\" & fso.GetTempName & "\"
fso.CreateFolder strTempPath
'------------------------------------------------------
Set f = fso.GetFile(Environ("UserProfile") & "\Documents\Bed_code_tbl.xlsx")
fso.CopyFile f.Path, strTempPath & f.NAME
'----------------------------------------------------------------------
You can get folder location for Your access file. And place created file relative to that location.
Alternatively ask user for the location.

Exporting Results Of A Querydef To The Active Excel Worksheet

Help! I have a database that I'm using to open an Excel template, export the results of a QueryDef to the acitve worksheet, then save that file with a new file name. Sounds easy enough. The problem that I'm running into is getting the results to export into an active worksheet by using DoCmd.TransferSpreadsheet. It does everything that I need it to, except for actually transfering the data... Which means, it's pretty much useless. Any help would be GREATLY appreciated. I'm about to pull my hair out. Thank you in advance.
Creating the QDF
Set qdf = db.CreateQueryDef("" & strCrt, "SELECT [Zones Asset Information].* FROM " & _
"[Zones Asset Information] WHERE [Zones Asset Informaiton].[Invoice Number] " = '" & strCrt & "';")
Opening the Template
Set xlWB = xlApp.Workbooks.Open(WB_PATH)
Set xlWS = xlWB.Sheets(3)
xlWS.Activate
Trying to Export
DoCmd.TransferSpreadsheet acExport, 10, "" & strCrt, , True, "orig data" 'Don't know how to specify Active Worksheet instead of a filename?!?
DoCmd.DeleteObject acQuery, "" & strCrt
Saving the File
sSaveAsFileName = FLDR_PATH & "Accounting_Breakdown_Zones_Invoice_xxxxxx.xlsx"
Debug.Print "sSaveAsFileName: " & sSaveAsFileName
xlWB.SaveAs sSaveAsFileName
There are two ways of exporting data from Access to Excel:
Opening an MsExcel object and using its methods to manipulate the Excel
Exporting data using the TransferSpreadsheet method
You are doing a mix of both, which is why you are not getting the result.
TransferSpreadsheet will export the given query to the specified file, but you cannot specify the worksheet.
If specifying worksheet is important, you will have to do it with an Excel object, and send the information cell by cell, a lot more work, if it justifies the cause.
E Mett, Thank you for the direction. Had to rework the process which doesn't 100% agree with the post title now, but thought I would share in case anyone else needed something similar. Thanks again!!
Private Sub ExportTable_MultipleWB()
Dim db As DAO.Database, rs As DAO.Recordset, rs2 As DAO.Recordset, strFilter As String, strFilter2 As String, _
sSaveAsFileName As String
Dim xlApp As Excel.Application, xlWB As Excel.Workbook, xlWS As Excel.Worksheet
Dim bolIsExcelRunning As Boolean
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT DISTINCT [mytable].[PO Number], [mytable].[Invoice Number] " & _
"FROM [mytable] ORDER BY [mytable].[PO Number], [mytable].[Invoice Number];", dbOpenSnapshot)
rs.MoveFirst
Do While Not rs.EOF
strFilter = rs.Fields(1).Value
strFilter2 = rs.Fields(0).Value
Set rs2 = db.OpenRecordset("SELECT [mytable].* FROM [mytable] WHERE [mytable].[Invoice Number] = '" & strFilter & "';")
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
Else
bolIsExcelRunning = True
End If
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open(WB_PATH)
Set xlWS = xlWB.Sheets(3)
xlWS.Activate
With xlWS
For iCols = 0 To rs2.Fields.Count - 1
xlWS.Cells(1, iCols + 1).Value = rs2.Fields(iCols).Name
Next
xlWS.Range(xlWS.Cells(1, 1), _
xlWS.Cells(1, rs2.Fields.Count)).Font.Bold = True
xlWS.Range("A2").CopyFromRecordset rs2
End With
sSaveAsFileName = FLDR_PATH & "myfilename_" & strFilter & "_PO-" & strFilter2 & ".xlsx"
Debug.Print "sSaveAsFileName: " & sSaveAsFileName
xlWB.SaveAs sSaveAsFileName
Set xlWS = Nothing
xlWB.Close False
Set xlWB = Nothing
rs.MoveNext
Loop
rs.Close
rs2.Close
If Not bolIsExcelRunning Then
xlApp.Quit
End If
Set xlApp = Nothing
Set rs = Nothing
Set rs2 = Nothing
Set db = Nothing
End Sub

Keeping multiple file names while importing via transfertext

Private Sub Command38_Click()
Dim f As Object
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strUpdate As String
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Dim P As String
Dim DeleteEverything As String
DoCmd.SetWarnings False
DeleteEverything = "DELETE * FROM [ucppltr]"
DoCmd.RunSQL DeleteEverything
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
f.InitialFileName = "S:\Formware\outfile\ucppt12\Storage"
f.Filters.Clear
f.Filters.Add " Armored TXT Files", "*.asc"
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
P = strFolder & strFile
DoCmd.TransferText acImportDelim, "UCPP Import Specification", "ucppltr", P, False
Next
End If
strUpdate = "PARAMETERS fileName Text;" & vbCrLf & _
"UPDATE ucppltr" & vbCrLf & _
"Set [File Name] = fileName"
Debug.Print strUpdate
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", strUpdate)
qdf.Parameters("fileName") = strFile
qdf.Execute dbFailOnError
Set qdf = Nothing
Set db = Nothing
Set f = Nothing
MsgBox DCount("*", "ucppltr") & " Records were imported"
End Sub
As you can see from the code on import I want to store the file name and while it does work it doesn't work exactly how I need it to. When we do work for this client it is 5 files ate a time once a week so I would like it to save all 5 file names however it only saves the last one it imports. My question, is there a way to save each file name to each one ( I doubt that) or can I save all 5 file names to all the records I import instead of just the last file name?
I always have the option of only allowing a single import and making them import and append the table 5 times I just wanted to check to see if there is a more efficent way before doing so.
Thanks in advance for any help in this matter!
There is a problem in your logic. Inside the loop, strFile holds the current file name. So after your loop is finished, only the current (=last) file name is passed on to the query.
I made some changes, so the filenames are now stored in the new variable strFileList, delimited by a ";". Please check, if this is a feasible solution.
Private Sub Command38_Click()
Dim f As Object
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strUpdate As String
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Dim P As String
Dim DeleteEverything As String
' Variable to hold file list
Dim strFileList As String
DoCmd.SetWarnings False
DeleteEverything = "DELETE * FROM [ucppltr]"
DoCmd.RunSQL DeleteEverything
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
f.InitialFileName = "S:\Formware\outfile\ucppt12\Storage"
f.Filters.Clear
f.Filters.Add " Armored TXT Files", "*.asc"
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
P = strFolder & strFile
DoCmd.TransferText acImportDelim, "UCPP Import Specification", "ucppltr", P, False
'Add file name to file list
strFileList = strFileList & strFile & ";"
Next
End If
strUpdate = "PARAMETERS fileName Text;" & vbCrLf & _
"UPDATE ucppltr" & vbCrLf & _
"Set [File Name] = fileName"
Debug.Print strUpdate
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", strUpdate)
'Pass file list to query
qdf.Parameters("fileName") = strFileList
qdf.Execute dbFailOnError
Set qdf = Nothing
Set db = Nothing
Set f = Nothing
MsgBox DCount("*", "ucppltr") & " Records were imported"
End Sub

VBA Code for Dynamic VLookup Between Two Open Spreadsheets from MS Access 2010

I've taken a different approach to a work project and I'm running into a wall. I've Google'd everything that I can think to Google and searched multiple forums before coming back to S.O. to ask for more help. I have a form in Access that let's users enter a customer/division combination, checks to make sure that there is an existing file path for that customer, then opens excel template files and saves them to the correct folder with a customer specific file name. This all seems to be working fine. Here's the part that has me completely stumped. The next part of this would be to open two of the excel files assigning, the Workbooks as variables xlWB1 and xlWB2 and the Worksheets as xlWS1 and xlWS2(Sheet1). I need to start in xlWB1.xlWS1.(cell D2) and do a VLookup on the value (item number) of that cell against the values of the cells in the range xlWB2.xlWS2.Range(D2:D1937). My hope was to count the total number of rows in each worksheet before starting the VLookup so that I could assign that value to a variable and use that variable to define the bottom of the range. I'm going to apologize in advance if the answer to this is something simple. I've never tried to perform any operations in Excel from Access using VBA, so I'm also struggling with the syntax. Please let me know if my question isn't clear or if there is any additional information that you need. I've pasted my starting code below.
UPDATED CODE IN CASE ANYONE ELSE NEEDS TO USE IT! THANK YOU ALL FOR THE HELP!!
Sub modExcel_SixMonth()
Const WB_PATH As String = "\\FMI-FS\Users\sharp-c\Desktop\TestDir\"
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim xlRng As Excel.Range
Dim rCount As Long
Dim xlWB2 As Excel.Workbook
Dim xlWS2 As Excel.Worksheet
Dim rCount2 As Long
Dim sFormula As String
Dim i As Long
Dim xlSheetName As String
Dim bolIsExcelRunning As Boolean
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
Else
bolIsExcelRunning = True
End If
xlApp.Visible = False
Set xlWB = xlApp.Workbooks.Open(WB_PATH & "acct 900860 Kentucky RSTS.xlsx")
Set xlWS = xlWB.Sheets(1)
Set xlWB2 = xlApp.Workbooks.Open(WB_PATH & "acct 900860 six months.xlsx")
Set xlWS2 = xlWB2.Sheets(1)
xlSheetName = xlWS2.Name
' rCount: RSTS Row Count
rCount = xlWS.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
Debug.Print "rCount : " & rCount
' rCount2: 6 Months Row Count
rCount2 = xlWS2.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
Debug.Print "rCount2 : " & rCount2
xlWS.Activate
With xlWS
For i = 2 To rCount
sFormula = "=VLOOKUP(C" & i & ", '" & WB_PATH & "[" & "acct 900860 six months.xlsx" & "]" & _
xlSheetName & "'!$D$2:$D$" & rCount2 & ", 1, 0)"
Debug.Print sFormula
.Range("D" & i).Formula = sFormula
DoEvents
Next
End With
xlWB.Save
xlWB2.Close False 'Closes WB Without Saving Changes
Set xlWB2 = Nothing
Set xlWS = Nothing
xlWB.Close
Set xlWB = Nothing
If Not bolIsExcelRunning Then
xlApp.Quit
End If
Set xlApp = Nothing
End Sub
I think this is maybe closer to what you need. Only need a single instance of excel for both workbooks...
Sub modExcel_SixMonth()
Const WB_PATH As String = "C:\Documents and Settings\Chris\Desktop\TestDir\"
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Dim xlRng As Excel.Range
Dim rCount As Long
Dim xlWB2 As Excel.Workbook
Dim xlWS2 As Excel.Worksheet
Dim xlRng2 As Excel.Range
Dim rCount2 As Long
Dim sFormula As String
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open(WB_PATH & "acct 900860 Kentucky RSTS.xlsx")
Set xlWS = xlWB.Sheets(1)
Set xlWB2 = xlApp.Workbooks.Open(WB_PATH & "acct 900860 six months.xlsx")
Set xlWS2 = xlWB2.Sheets(1)
' rCount: RSTS Row Count
rCount = xlWS.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count - 1
Debug.Print "rCount : " & rCount
' rCount2: 6 Months Row Count
rCount2 = xlWS2.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count - 1
Debug.Print "rCount2 : " & rCount2
sFormula = "=VLOOKUP(C2," & xlWS2.Range("D2:D1937").Address(True, True, , True) & _
",1,FALSE)"
Debug.Print sFormula
With xlWS
.Range("D2").Formula = sFormula
End With
End Sub
Have you tried using the same application object? I believe this was a comment on this question earlier.
Additionally, if this doesn't work, you could use the find method of the range object. I.e.
XLWB2.Range("Your range here").find(XLWB1.Range( _
"Cell containing value you're looking for").Value,lookat:=xlwhole)