VBA Access: Files with Nulls - ms-access

Overall Goal:
Pull all files from folder > format files in staging table > copy staging table to master table > kill staging table > rinse and repeat until all files have been taken from folder, formatted and put into the master table.
Issue:
I have apparently not taken into account that some of the files sent to me will have blank worksheets (rather they may have a value that says "No Data" in cell A1). When my macro hits the "No Data" or blank sheet I get a Null error (94).
What I've tried:
strF1Data = Nz(!ref_val)
strF1Data = Nz(!ref_val,"")
Suspicions:
I think I can update the SQL UPDATE line to allow Nulls, but I feel like a more efficient solution would be to skip if null. However I have tried modifying the Do Until statement and had no luck...
Possibly Worth Mentioning:
The files have multiple worksheets. I learned this the hard way in finding this error on a random worksheet between several other worksheets that did have data.
Code: (to help save some space, I'm only giving the call files bit and formatting piece, I don't think the other pieces will be of any use. However if you would like them then let me know.)
The overall macro (see next code sections for piece with error):
Sub Pull_File_into_Staging_Table()
'Process:
'1 - Loop through all files saved to specified folder making an internal list of the files
'2 - Paste one files content to staging table at a time
'3 - Format the information in the staging table
'4 - Copy formatted staging table to 1Compare Table (master table)
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim filename As String
Dim path As String
DoCmd.SetWarnings False
path = "C:\Users\USER\Desktop\Test\"
Dim rs As DAO.Recordset ' Moved from below
Dim db As DAO.Database
Set db = CurrentDb
'Loop through the folder & build file list
strFile = Dir(path & "*.xls")
While strFile <> ""
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()
Wend
'see if any files were found
If intFile = 0 Then
MsgBox "No files found"
Exit Sub
End If
'cycle through the list of files
For intFile = 1 To UBound(strFileList)
filename = path & strFileList(intFile)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, "Stage", filename, False
Call Format_Staging_Table
Call Copy_from_Stage_to_Master
Call Clear_Staging_Table
Next intFile
DoCmd.SetWarnings True
End Sub
The piece with the issue:
Sub Format_Staging_Table()
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim filename As String
Dim path As String
DoCmd.SetWarnings False
path = "C:\Users\USER\Desktop\Test\"
Dim rs As DAO.Recordset ' Moved from below
Dim db As DAO.Database
Set db = CurrentDb
CurrentDb.Execute ("ALTER TABLE Stage ADD COLUMN UPC Text, SR_Profit_Center Text, SR_Super_Label Text, SAP_Profit_Center Text, SAP_Super_Label Text;")
CurrentDb.TableDefs("Stage").Fields("F1").Name = "ref_val"
Dim ref_val As String
Set rs = db.OpenRecordset("SELECT TOP 1 ref_val FROM Stage;", dbOpenDynaset)
ref_val = rs.Fields(0).Value
rs.Close
db.Execute "DELETE FROM [Stage] WHERE ref_val = '" & ref_val & "';"
Const YOUR_TABLE_NAME As String = "Stage"
Dim SQL_UPDATE_DATA As String
SQL_UPDATE_DATA = "SELECT *, ';' & '" & ref_val & "' FROM [" & YOUR_TABLE_NAME & "] WHERE SR_Profit_Center Is Null"
Dim strF1Data As String
Dim varData As Variant
Set rs = CurrentDb.OpenRecordset(SQL_UPDATE_DATA)
With rs
Do Until .EOF
strF1Data = !ref_val
varData = Split(strF1Data, ";")
If UBound(varData) = 4 Then
.Edit
!ref_val = ref_val
!UPC = varData(0)
!SR_Profit_Center = varData(1)
!SR_Super_Label = varData(2)
!SAP_Profit_Center = varData(3)
!SAP_Super_Label = varData(4)
.Update
End If
.MoveNext
Loop
.Close
End With
Set rs = Nothing
End Sub
Also I'm aware of the extra variable pieces, I will clean it up once I get it working.
File Examples:
Working File:
CE16041901
00791558441123;US1K100017;CGR;US1K100001;UNKNOW
00791558442328;US1K100017;CGR;US1K100001;UNKNOW
00791558440720;US1K100017;CGR;US1K100001;UNKNOW
00791558444629;US1K100017;CGR;US1K100001;UNKNOW
00791558440522;US1K100017;CGR;US1K100001;UNKNOW
00791558443325;US1K100017;CGR;US1K100001;UNKNOW
Not Working File:
CE16042001
00791558334128;US1K100017;CGR;US1K100001;UNKNOW
00791558159523;US1K100017;CGR;US1K100001;UNKNOW
00602547736604;US1A100018;UR;US1A100018;US-RU
I appreciate any help. I ran with this as far as I could, but I am still very much a novice when it comes to access and vb. If you need more information or clarification please let me know and I'll do my best to provide/explain.

No need to touch the staging table functions. Simply conditionally populate the strFileList array depending if Excel workbooks' first sheet contains No Data or empty cell. Recall Access VBA has complete access to all Excel objects via COM interface or Excel VBA reference and so can iteratively open workbooks. Hence, adjust your While/Wend loop accordingly:
Sub Pull_File_into_Staging_Table()
'...same code...
Dim objXL As Object
Dim wb As Object
Set objXL = CreateObject("Excel.Application")
strfile = Dir(Path & "*.xls")
While strfile <> ""
Set wb = objXL.Workbooks.Open(Path & strfile)
If wb.Sheets(1).Range("A1") <> "No Data" AND wb.Sheets(1).Range("A1") <> "" Then
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strfile
End If
strfile = Dir()
wb.Close False
Set wb = Nothing
Wend
'...

Related

Get contents of laccdb file through VBA

I want to be able to view the contents of my access database's laccdb file through VBA so I can use it to alert users (through a button) who else is in the database.
I specifically don't want to use a 3rd Party tool. I have tried using:
Set ts = fso.OpenTextFile(strFile, ForReading)
strContents = ts.ReadAll
This works fine if only 1 user is in the database. But for multiple users it gets confused by the presumably non-ASCII characters and goes into this kind of thing after one entry:
Does anyone have any suggestions? It's fine if I just open the file in Notepad++...
Code eventually used is as follows (I didn't need the title and have removed some code not being used):
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection, rs As New ADODB.Recordset
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Open "Data Source=" & CurrentDb.Name
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
While Not rs.EOF
Debug.Print rs.Fields(0)
rs.MoveNext
Wend
End Sub
I found this which should help, it's not actually reading the ldb file, but it has the info that you need (Source: https://support.microsoft.com/en-us/kb/198755):
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection
Dim cn2 As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, j As Long
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open "Data Source=c:\Northwind.mdb"
cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=c:\Northwind.mdb"
' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4 OLE DB provider. You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
'Output the list of all users in the current database.
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name
While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), _
rs.Fields(2), rs.Fields(3)
rs.MoveNext
Wend
End Sub
I put together some code to read through the lock file and output a message listing users currently using the system.
Trying to read the whole file in at once seems to result in VBA treating the string as Unicode in the same way notepad does so I read in character by character and filter out non printing characters.
Sub TestOpenLaccdb()
Dim stm As TextStream, fso As FileSystemObject, strLine As String, strChar As String, strArr() As String, nArr As Long, nArrMax As Long, nArrMin As Long
Dim strFilename As String, strMessage As String
strFilename = CurrentProject.FullName
strFilename = Left(strFilename, InStrRev(strFilename, ".")) & "laccdb"
Set fso = New FileSystemObject
Set stm = fso.OpenTextFile(strFilename, ForReading, False, TristateFalse) 'open the file as a textstream using the filesystem object (add ref to Microsoft Scripting Runtime)
While Not stm.AtEndOfStream 'Read through the file one character at a time
strChar = stm.Read(1)
If Asc(strChar) > 13 And Asc(strChar) < 127 Then 'Filter out the nulls and other non printing characters
strLine = strLine & strChar
End If
Wend
strMessage = "Users Logged In: " & vbCrLf
'Debug.Print strLine
strArr = Split(strLine, "Admin", , vbTextCompare) 'Because everyone logs in as admin user split using the string "Admin"
nArrMax = UBound(strArr)
nArrMin = LBound(strArr)
For nArr = nArrMin To nArrMax 'Loop through all machine numbers in lock file
strArr(nArr) = Trim(strArr(nArr)) 'Strip leading and trailing spaces
If Len(strArr(nArr)) > 1 Then 'skip blank value at end
'Because I log when a user opens the database with username and machine name I can look it up in the event log
strMessage = strMessage & DLast("EventDescription", "tblEventLog", "[EventDescription] like ""*" & strArr(nArr) & "*""") & vbCrLf
End If
Next
MsgBox strMessage 'let the user know who is logged in
stm.Close
Set stm = Nothing
Set fso = Nothing
End Sub

Need to make a button create a record and attach a file

It's my first post here and I love how helpful people are on this site!
I have very little experience with vba in general so bear with me. And before you ask, I have spent a lot of time searching for my answer on this site as well as msdn with no luck.
I am designing a database for my work to keep track of employees and their contact info, training courses, and hiring documentation. I have hit a small road block with the hiring forms.
I have a form with employee's information and a subform that has a list of all their documentation. Each document is a record on a separate "documents" table that is pulled up with a query. The table has a field for the employee name, the type of document (resume et cetera) and the attachment itself. I have a dropdown box that has a list of document types. When I select an option from the combo box I would like it to create a new record in the "documents" table using the employee name from the current employee being shown, the document type selected from the combo box, then open the choose file dialogue.
Here is what I have so far
I have read microsoft's article on adding attachments which was helpful but doesn't tell me how to create a new record on another table.
https://support.office.com/en-us/article/Attach-files-and-graphics-to-the-records-in-your-database-bced3638-bfbc-43f0-822d-374bca2e6b40?CorrelationId=5332de93-8a42-4f76-bb47-c196bc1ce75b&ui=en-US&rs=en-US&ad=US
Any help would be greatly appreciated :)
Update: I've come a long way with the code, but i am getting stuck with inserting the attachment
Sub test()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset2
Dim rsA As DAO.Recordset2
Dim fld As DAO.Field2
'variables for file path
Dim sName
Dim f As Object
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("documents")
Set fld = rst("doc")
Set rsA = fld.Value
rst.AddNew
rst!inspector = "test"
rst.Update
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
'MsgBox "Folder: " & strFolder & vbCrLf & _
"File: " & strFile
Next
End If
Set f = Nothing
sName = strFolder & strFile
rst.Edit
rst.AddNew
rsA("FileData").LoadFromFile sName ' <<<this is where i get stuck
rsA.Update
rst.Update
MsgBox ("done") 'test
End Sub
After banging my head against the desk for 2 days i finally have the code. I still need to make adjustments to fill in the other fields with the inspector name and the type of file, but it should be easy sailing from here. I was having the most trouble with creating a record and attaching a file
Sub test()
Dim dbs As DAO.Database
Dim tbl As DAO.Recordset2
Dim field As DAO.Recordset2
'variables for file path
Dim sName
Dim f As Object
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Set db = CurrentDb
Set tbl = db.OpenRecordset("documents")
'get file path string
Set f = Application.FileDialog(3)
f.AllowMultiSelect = False
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
Next
End If
Set f = Nothing
sName = strFolder & strFile
tbl.Edit
tbl.AddNew 'add a new entry to the table
tbl!inspector = "test"
Set field = tbl.Fields("doc").Value
field.AddNew 'add an attachment to the record
field.Fields("FileData").LoadFromFile sName
field.Update
tbl.Update
End Sub

Access - Export pipe delim CSV with headers using VBA

this is the first question I've posted so hopefully don't break any site rules! I have looked for the answer but can't seem to find quite what I'm looking for.
I have a piece of VB code which is exporting data but it's not including the column headers which I need.
I'm using Access 2010, and I'm exporting a pipe delimited CSV file to a folder location of my choice. I'm exporting from a table in access which has been created from a parent table using several queries, so it's basically just a table of results that I'm trying to export in CSV.
Here is the code I'm using that IS exporting as pipe delim CSV but not adding headers;
Private Sub BtnExportCSV_Click()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim intFile As Integer
Dim strFilePath As String
Dim intCount As Integer
Dim strHold
strFilePath = "I:\Data\test.csv"
Set db = CurrentDb
Set rst = db.OpenRecordset("T_Export_CSV", dbOpenForwardOnly)
intFile = FreeFile
Open strFilePath For Output As #intFile
Do Until rst.EOF
For intCount = 0 To rst.Fields.Count - 1
strHold = strHold & rst(intCount).Value & "|"
Next
If Right(strHold, 1) = "|" Then
strHold = Left(strHold, Len(strHold) - 1)
End If
Print #intFile, strHold
rst.MoveNext
strHold = vbNullString
Loop
Close intFile
rst.Close
Set rst = Nothing
MsgBox ("Export Completed Successfully")
End Sub
Thanks in advance for the help!
Scott
You need to write the Name-Property of the recordset fields to the file as well.
Insert this into your code to achieve that:
[...]
Open strFilePath For Output As #intFile
If Not rst.EOF Then
For intCount = 0 To rst.Fields.Count - 1
strHold = strHold & rst.Fields(intCount).Name & "|"
Next
If Right(strHold, 1) = "|" Then
strHold = Left(strHold, Len(strHold) - 1)
End If
Print #intFile, strHold
strHold = vbNullString
End If
Do Until rst.EOF
[...]

Adding DBfailonerror in access vb creates compile error invalid use of property

An import sub that has been created in access works OK but when DBfailonerror is added a compile error invalid use of property is encountered when the sub is run from the vb editor.
Any advice re: this would be most appreciated. Code is as follows:
Sub Importcl()
'DATA DECLARATIONS
Dim fso As New FileSystemObject
Dim t As TextStream
Dim strFilePath As String
Dim Cnr As String
Dim Cnri As String
Dim Cnrii As String
Dim Cnriii As String
Dim Sqlstr As String
Dim Db As DAO.Database
'SET COUNTERS TO ZERO
Cnr = 0
Cnri = 0
Cnrii = 0
Cnriii = 0
'Point to DB
Set Db = CurrentDb()
'SET TXT FILE PATH
strFilePath = "C:\Users\Vlad\CSV import\EV WORK\Book1.txt"
'ERROR HANLDER FOR TXT FILE PATH AND COUNTING OF TXT FILE LINE ITEMS
If fso.FileExists(strFilePath) Then
Set t = fso.OpenTextFile(strFilePath, ForReading, False)
Do While t.AtEndOfStream <> True
t.SkipLine
Cnr = Cnr + 1
Loop
t.Close
Else: MsgBox ("Txt File not Found - Check File Path")
Exit Sub
End If
'DISPLAY LINE RECORDS COUNTED IN TXT FILE TO BE ADDED TO TABLE
Debug.Print Cntr; " Incl header"
MsgBox (Cnr - 1 & " records to be added")
'COUNT & DISPLAY CURRENT RECORD COUNT IN TARGET TABLE
Cnri = DCount("[Case Date]", "All Caseload Data New")
If MsgBox(Cnri & " -Current Records in table- All Caseload Data New - Continue
with Import?", vbYesNo, "Import") = vbYes Then
Db.Execute _
"INSERT INTO [All Caseload Data New] SELECT * FROM[Text;FMT=Delimited;HDR=Yes;
DATABASE=C:\Users\Dev\CSV import\DEV WORK\].[Book1#txt];"
dbFailOnError
Db.TableDefs.Refresh
Else: Exit Sub
End If
Cnrii = DCount("[Case Date]", "All Caseload Data New")
Cnriii = Cnrii - Cnri
MsgBox (Cnriii & " New records added to table All Caseload Data New")
End Sub
With this code to start ...
Dim db As DAO.database
Dim strInsert As String
strInsert = "INSERT INTO tblFoo (some_text) VALUES ('bar');"
Set db = CurrentDb
Then these 2 Execute statements ..
db.Execute strInsert
dbFailOnError ' triggers error
db.Execute strInsert, dbFailOnError ' compiles without error
Include dbFailOnError on the same line as Execute. Placing dbFailOnError on a separate line triggers that "invalid use of property" compile error.

Is it possible to batch convert csv to xls using a macro?

I have a large amount of csv files that I need in .xls format. Is it possible to run a batch conversion with a macro or best done with another language?
I have used this code http://www.ozgrid.com/forum/showthread.php?t=71409&p=369573#post369573 to reference my directory but I'm not sure of the command to open each file and save them. Here's what I have:
Sub batchconvertcsvxls()
Dim wb As Workbook
Dim CSVCount As Integer
Dim myVar As String
myVar = FileList("C:\Documents and Settings\alistairw\My Documents\csvxlstest")
For i = LBound(myVar) To UBound(myVar)
With wb
Application.Workbooks.OpenText 'How do I reference the myvar string ?
wb.SaveAs '....
End With
Next
End Sub
Function FileList(fldr As String, Optional fltr As String = "*.*") As Variant
Dim sTemp As String, sHldr As String
If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
sTemp = Dir(fldr & fltr)
If sTemp = "" Then
FileList = Split("No files found", "|") 'ensures an array is returned
Exit Function
End If
Do
sHldr = Dir
If sHldr = "" Then Exit Do
sTemp = sTemp & "|" & sHldr
Loop
FileList = Split(sTemp, "|")
End Function
Edit: The files are .txt files formatted as csv
By combining the code given by Scott Holtzman and 'ExcelFreak', the conversion works quite well. The final code looks something like this:
Sub CSV_to_XLS()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "U:\path\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
wb.SaveAs Replace(wb.FullName, ".csv", ".xls"), 50 'UPDATE:
wb.Close True
Set wb = Nothing
strFile = Dir
Loop
End Sub
Opening the converted .xls file throws a warning everytime:
"The file you are trying to open, 'filename', is in a different format than specified by the file extension. Verify that the file is not corrupted and is from a trusted source before opening the file. Do you want to open the file now?"
Clicking Yes then opens the .xls file.
Is there a way to get rid of this warning message? Excel throws a warning everytime the .xls file is opened.
In a lot less lines of code, this should get you what you want. However, I will say this may not be the fastest way to get it done, because you are opening, saving, and closing the workbook every time. I will look for a faster way, but I forget the method off the top of my head.
Sub batchconvertcsvxls()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(strDir & strFile)
With wb
.SaveAs Replace(wb.FullName, ".csv", ".xls"), 50 'UPDATE:
.Close True
End With
Set wb = Nothing
Loop
End Sub
** UPDATE **
you need the proper fileformat enumeration for a .xls file. I think its 50, but you can check here Excel File Type Enumeration, if it's not.
The Code of Scott Holtzman nearly did it for me. I had to make two changes to get it to work:
He forgot to add the line that makes our loop continue with the next file. The last line before the Loop should read
strFile = Dir
The Workbooks.Open method did not read my CSV files as expected (the whole line ended up to be text in the first cell). When I added the parameter Local:=True it worked:
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
This works properly at least on Excel 2013. Using FileFormat:=xlExcel8 parameter instead of the filetype tag 50 creates files that open without security nags.
Sub CSV_to_XLS()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\temp\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
wb.SaveAs Replace(wb.FullName, ".csv", ".xls"), FileFormat:=xlExcel8
wb.Close True
Set wb = Nothing
strFile = Dir
Loop
End Sub
This was a good question and I have found in the internet several answers. Just making very small changes (I couldn't edit any of the codes already published) I could make things work a bit better:
Sub CSV_to_XLSX()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\Users\acer\OneDrive\Doctorado\Study 1\data\Retest Bkp\Day 1\Sart\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
With wb
.SaveAs Replace(wb.FullName, ".csv", ".xlsx"), 51
.Close True
End With
Set wb = Nothing
strFile = Dir
Loop
End Sub