the code first changes the dbf file to csv.
Sub FindFiles()
Dim strDocPath As String
Dim strCurrntFile As String
Dim Fname As String
strDocPath = "Y:\Eilat\Shapes\"
'strCurrentFile = Dir(strDocPath & "*.*")
strCurrentFile = Dir(strDocPath & "111.dbf")
Workbooks.Open FileName:=strDocPath & strCurrentFile
Fname = Left$(strCurrentFile, Len(strCurrentFile) - 4) & ".csv"
ActiveWorkbook.SaveAs FileName:=strDocPath & Fname, FileFormat:=xlCSVMSDOS, CreateBackup:=False
ActiveWorkbook.Close (True)
Dim filepath As String
Dim sqlinsert As String
Dim sqlvalue As String
Dim sqlquery As String
Dim sqlwhere As String
'Set db = CurrentDb
directory = "Y:\Eilat\Shapes\"
FileName = "111.csv"
Set rs = CreateObject("ADODB.Recordset")
strcon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & directory & ";" _
& "Extended Properties=""text;HDR=Yes;FMT=Delimited"";"
'strSQL = "SELECT * FROM " & FileName
'rs.Open strSQL, strcon
'rs.MoveFirst
Dim strTextLine As String
Dim aryMyData() As String
Open directory & FileName For Input As #1
Do While Not EOF(1) ' Loop until end of file.
Line Input #1, strTextLine ' Read line into variable.
aryMyData = Split(strTextLine, ",") 'Split text into array by comma
' (the csv length changes for example this is the columns in csv but it can be longer. EHANDLE,UseCode,UseCode2,Descriptio,Gush,Helka,Owner,OwnerID,Holder,HolderID,Floor,PhysicalNo,Date,Area,Comments,Address,StreetName,HouseNo,Telephone,Fax,Email,Manager,Business,SerialNo,MeasuredBy,Height,BlockNo,Mapkey,User1,User2,user3 is the columns in csv but it can be longer.
strSQL = "??(what sql statement need??)
(dont know how to do import to mdb "Y:\Eilat\Arnona\Eilat.mdb")
Debug.Print strSQL
DoCmd.RunSQL strSQL
Loop
Close
End Sub
With the assumptions:
Your code properly opens the CSV file and reads line by line
All your table fields are of type String
Your table has fields Field_01, Field_02, Field_03 into which you
want to import columns 1, 2 and 3 of the CSV file
You can use
DoCmd.RunSQL "INSERT INTO MyTable (Field_01, Field_02, Field_03) VALUES ('" & aryMyData(0) & "','" & aryMyData(1) & "','" & aryMyData(2) & "'")
and expand as needed for all your fields and columns.
This is a very basic example that assumes your table is specifically prepared for the CSV file you are importing. If you expect the table's design to change to accommodate whatever CSV file you are importing that is way more complicated.
Related
I have the following Module in Access:
On Error Resume Next
Dim strDir As String
Dim strFile As String
Dim I As Long
I = 0
strDir = "C:\excelTest\"
strFile = Dir(strDir & "*.xlsx")
While strFile <> ""
I = I + 1
strFile = strDir & strFile
Debug.Print "importing " & strFile
DoCmd.TransferSpreadsheet acImport, , "mainTable", strFile, False 'has columnheaders
strFile = Dir()
Wend
MsgBox "Load Finished"
importExcelSheets = I
End Function
This imports the data from the xlsx files within the directory (C:\excelTest). This all works fine, but how can I add an additional field which stores the directory and file?
ie. If I have a file test.xlsx during the import a field is created and the path C:\excelTest\test.xlsx is stored.
After records are imported, run an SQL UPDATE action with criteria that distinguishes those new records from previously existing, possibly a date value. Something like:
CurrentDb.Execute "UPDATE tablename SET fieldname = '" & strFile & "' WHERE datefield = #" & <some date input here> & "#"
I would like to query an UTF-8 encoded CSV file using VBA in Excel 2010 with the following database connection:
provider=Microsoft.Jet.OLEDB.4.0;;data source='xyz';Extended Properties="text;HDR=Yes;FMT=Delimited(,);CharacterSet=65001"
All CSV files start with the BOM \xEF\xBB\xBF and the header line. Somehow the BOM isn't recognized correctly and the first column header gets read as "?header_name", i.e. a question mark gets prepended. I have tried different CharacterSets and I have also tried to use Microsoft.ACE.OLEDB.12.0, but everything was without success so far.
Is this a known bug or is there any way to get the right first column header name without changing the encoding of the source files?
The following procedure extracts the entire CSVfile into a new Sheet, clearing the BOM from the Header. It has the Path, Filename and BOM string as variables to provide flexibility.
Use this procedure to call the Query procedure
Sub Qry_Csv_Utf8()
Const kFile As String = "UTF8 .csv"
Const kPath As String = "D:\StackOverFlow\Temp\"
Const kBOM As String = "\xEF\xBB\xBF"
Call Ado_Qry_Csv(kPath, kFile, kBOM)
End Sub
This is the Query procedure
Sub Ado_Qry_Csv(sPath As String, sFile As String, sBOM As String)
Dim Wsh As Worksheet
Dim AdoConnect As ADODB.Connection
Dim AdoRcrdSet As ADODB.Recordset
Dim i As Integer
Rem Add New Sheet - Select option required
'With ThisWorkbook 'Use this if procedure is resident in workbook receiving csv data
'With Workbooks(WbkName) 'Use this if procedure is not in workbook receiving csv data
With ActiveWorkbook 'I used this for testing purposes
Set Wsh = .Sheets.Add(After:=.Sheets(.Sheets.Count))
'Wsh.Name = NewSheetName 'rename new Sheet
End With
Set AdoConnect = New ADODB.Connection
AdoConnect.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sPath & ";" & _
"Extended Properties='text;HDR=Yes;FMT=Delimited(,);CharacterSet=65001'"
Set AdoRcrdSet = New ADODB.Recordset
AdoRcrdSet.Open Source:="SELECT * FROM [" & sFile & "]", _
ActiveConnection:=AdoConnect, _
CursorType:=adOpenDynamic, _
LockType:=adLockReadOnly, _
Options:=adCmdText
Rem Enter Csv Records in Worksheet
For i = 0 To -1 + AdoRcrdSet.Fields.Count
Wsh.Cells(1, 1 + i).Value = _
WorksheetFunction.Substitute(AdoRcrdSet.Fields(i).Name, sBOM, "")
Next
Wsh.Cells(2, 1).CopyFromRecordset AdoRcrdSet
End Sub
The only solution for this problem I found is to use Schema.ini file.
my test csv file
Col_A;Col_B;Col_C
Some text example;123456789;3,14
Schema.ini for my test csv file
[UTF-8_Csv_With_BOM.csv]
Format=Delimited(;)
Col1=Col_A Text
Col2=Col_B Long
Col3=Col_C Double
This Schema.ini file contains the name of the source csv file and describes my columns. Each column is specified by its name and type but you can specify more informations. This file must be located in the same folder as your csv file. More info here.
Finally the VBA code which reads the csv file. Note that HDR=No. This is because the columns headers are defined in the Schema.ini.
' Add reference to Microsoft ActiveX Data Objects 6.1 Library
Sub ReadCsv()
Const filePath As String = "c:\Temp\StackOverflow\"
Const fileName As String = "UTF-8_Csv_With_BOM.csv"
Dim conn As ADODB.Connection
Dim rs As New ADODB.Recordset
Set conn = New ADODB.Connection
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & filePath & _
"';Extended Properties='text;HDR=No;FMT=Delimited()';"
With rs
.ActiveConnection = conn
.Open "SELECT * FROM [" & fileName & "]"
If Not .BOF And Not .EOF Then
While (Not .EOF)
Debug.Print rs.Fields("Col_A") & " " & _
rs.Fields("Col_B") & " " & _
rs.Fields("Col_C")
.MoveNext
Wend
End If
.Close
End With
conn.Close
Set conn = Nothing
End Sub
Output
Some text example 123456789 3,14
I have a folder that contains 2000 *.csv files. But not all of them are important 4 me. Only 60 of them are important, and I have them listed, by names in access table. there is no header - only file names that need to be read into the single table database.
it looks like this:
these *.mst files are really *.csv files - it will work that way.
I need a VBA procedure, that imports ONLY SELECTED files (these listed in the table) out of this folder into a single access table.
yes, all these files have exactly the same structure, so they can be merged into these access table and that is the goal of this VBA procedure.
this is how every file looks like:
the code I already got just pulls every file from this folder and imports it into the single table in access.
I need it changed to pull only the selected files.
destination table name is: "all_stocks"
Sub Importing_data_into_a_single_table()
Dim start As Double
Dim total_time As String
Dim my_path As String, my_ext As String, my_file As String
Dim FileNum As Integer
Dim DataLine As String
Dim pola() as String
Dim SQL1 As String, file_array() As String
start = Timer
my_path = "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\" 'Source folder.
my_ext = "*.mst" ' all files with .mst extension.
my_file = Dir(my_path & my_ext) ' take the first file from my_path.
DoCmd.SetWarnings False ' turn off warnings.
Do While my_file <> ""
FileNum = FreeFile()
Open my_path & my_file For Input As #FileNum
Line Input #FileNum, DataLine
' Reads a single line from an open sequential file and assigns it to a String variable.
While Not EOF(FileNum) ' EOF function returns a Boolean value True when the end of a file.
Line Input #FileNum, DataLine
pola = Split(DataLine, ",")
SQL1 = "INSERT INTO Tabela1 (Ticker, day, open, high, low, close, vol) VALUES('" & pola(0) & "', " & _
pola(1) & ", " & pola(2) & ", " & pola(3) & ", " & _
pola(4) & ", " & pola(5) & ", " & pola(6) & ")"
Debug.Print SQL1
DoCmd.RunSQL SQL1
Wend
Close
my_file = Dir()
Loop
DoCmd.SetWarnings True
total_time = Format((Timer - start) / 86400, "hh:mm:ss")
' total_time = Round(Timer - start, 3)
MsgBox "This code ran successfully in " & total_time & " minutes", vbInformation
End Sub
If You could optimize this code to run faster, please be my guest.
Now its importing the data using "Line Input" method, and I've heard, that there are some better ways to do that, but I'm no programmer myself so I'm dependent on Your help my friends.
Thank U for all help and code provided :-)
screen shot 4 for A.S.H
Listing the 2000+ files in the directory, checking if each is listed in the selection table, is not the right approach. It is surely preferable to read the selected files from the table and access them one by one.
The other potential speedup is using the built-in DoCmd.TransferText (as already pointed in other answers). Built-ins are usually very optimized and robust so you should prefer them unless there's a specific reason. Your own tests should confirm it.
Sub Importing_data_into_a_single_table()
Dim my_path As String, rs As Recordset, start As Double, total_time As String
my_path = "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\" 'Source folder.
DoCmd.SetWarnings False
start = Timer
Set rs = CurrentDb.OpenRecordset("Selected_Files")
Do Until rs.EOF
If Dir(my_path & rs.Fields(0).Value) <> "" Then
DoCmd.TransferText , , "Tabela1", my_path & rs.Fields(0).Value, True
' You could also use your code's loop here; Open my_path & my_file For Input As #FileNum etc..
End If
rs.MoveNext
Loop
DoCmd.SetWarnings True
total_time = Format(Timer - start, "hh:mm:ss")
MsgBox "This code ran successfully in " & total_time, vbInformation
End Sub
I would try using a combination of different method. I will admit I have never interacted with a .mst file in the manner youre using them but I think what IM suggesting will still work perfectly fine.
Use this to check table for file name:
Do While my_file <> "" 'some where after this line
If Isnull(Dlookup("your field name", "your table name", "Field name='" & my_file & "'") = False then
'do stuff b/c you found a match
else
'dont do stuff b/c no match
end if
Then you could use DoCmd.TransferText to import the entire file into the table
Documentation of transfer text method
https://msdn.microsoft.com/VBA/Access-VBA/articles/docmd-transfertext-method-access
I use frequently Excel vba. This bellows is Excel vba method. Compare the speed of this with your method.
Sub OpenCSvs()
Dim sWs As String, Fn As String
Dim Wb As Workbook
Dim start As Double
Dim total_time As String
Dim my_path As String, my_ext As String, my_file As String
start = Timer
my_path = "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\" 'Source folder.
my_ext = "*.mst" ' all files with .mst extension.
my_file = Dir(my_path & my_ext) ' take the first file from my_path.
Do While my_file <> ""
Fn = my_path & my_file
Set Wb = Workbooks.Open(Fn, Format:=2)
sWs = ActiveSheet.Name
With ActiveSheet
.Rows(1).Insert
.Range("a1").Resize(1, 7) = Array("Ticker", "day", "open", "high", "low", "close", "vol")
End With
ExportToAccess Fn, sWs
Wb.Close (0)
my_file = Dir()
Loop
total_time = Format((Timer - start) / 86400, "hh:mm:ss")
MsgBox "This code ran successfully in " & total_time & " minutes", vbInformation
End Sub
Sub ExportToAccess(myFn As String, sWs As String)
Dim PathOfAccess As String
Dim strConn As String, strSQL As String
PathOfAccess = "C:\Database6.accdb" '<~~ your database path
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & PathOfAccess & ";"
Set cn = CreateObject("ADODB.Connection")
cn.Open strConn
strSQL = "INSERT INTO Tabela1 (Ticker, day, open, high, low, close, vol) select * from [" & sWs & "$] IN '' " _
& "[Excel 8.0;HDR=yes;IMEX=2;DATABASE=" & myFn & "]"
cn.Execute strSQL
End Sub
I need to scrub a regularly received Access database so that all of its tables can be exported to "clean" CSVs and then imported by Base SAS via PROC IMPORT.
I am not experienced with Access VBA or programming in general, but I attempted to kitbash a script to loop through every field in every table and replace certain characters. It doesn't appear to work and I get several "Type Conversion Failure" errors while it's running.
Public Sub ReplaceCharAllTables()
Dim strSQL As String
Dim fld As DAO.Field
Dim db As DAO.Database
Set db = CurrentDb()
Dim obj As AccessObject, dbs As Object
Set dbs = Application.CurrentData
' Cycle through all tables in database
For Each obj In dbs.AllTables
' Cycle through all fields in the table
For Each fld In db.TableDefs("[" & obj.Name & "]").Fields
If fld.Type = dbText And Not IsNull(fld) Then
strSQL = "Update [" & obj.Name & "] Set [" & fld.Name & "]= Replace([" & fld.Name & "],Chr(10),'. ')"
DoCmd.RunSQL strSQL
strSQL = "Update [" & obj.Name & "] Set [" & fld.Name & "]= Replace([" & fld.Name & "],Chr(13),'. ')"
DoCmd.RunSQL strSQL
End If
Next
Next obj
End Sub
Note that this particular code current only attempts to remove two characters. It's just a temporary testbed.
EDIT 2016.11.30: Just wanted to say that Andre's solution was perfect. I ended up needing to make a couple minor tweaks, particularly to also look at "memo" fields in addition to text fields and to write the helpful debug info to a text file rather than to the size-limited Immediate Window. Looping through an array of character codes was deceptively clever.
Public Sub ReplaceCharAllTables()
Dim strSQL As String
Dim fld As DAO.Field
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim strFld As String
Dim arCharCodes As Variant
Dim code As Variant
Dim strFolder As String
Dim n As Integer
Dim strUpdate As String
' Get stuff setup save debug.print log file
strFolder = Application.CurrentProject.Path & "\" & Application.CurrentProject.Name & "_RemoveCharLog.txt"
n = FreeFile()
Open strFolder For Output As #n
' all charcodes to replace
arCharCodes = Array(10, 13, 44)
Set db = CurrentDb()
' Cycle through all tables in database
For Each td In db.TableDefs
' Ignore system tables
If Not (td.Name Like "MSys*" Or td.Name Like "USys*") Then
' Cycle through all fields in the table
For Each fld In td.Fields
If fld.Type = dbText Or fld.Type = dbMemo Then ' Check if field is text or memo
' Cycle through all character codes to remove
For Each code In arCharCodes
strFld = "[" & fld.Name & "]"
strSQL = "UPDATE [" & td.Name & "] " & _
"SET " & strFld & " = Replace(" & strFld & ", Chr(" & code & "), '. ') " & _
"WHERE " & strFld & " LIKE '*" & Chr(code) & "*'"
db.Execute strSQL
strUpdate = "Updated " & db.RecordsAffected & " records."
'Start printing logs
Debug.Print strSQL
Debug.Print strUpdate
Print #n, strSQL
Print #n, strUpdate
Next code
End If
Next fld
End If
Next td
End Sub
In principal there is nothing wrong with your code as far as I can see. The main problem may be that it also attempts to update all system tables - check "System objects" in the Navigation options of the navigation pane to see them.
They start with MSys or USys.
A few other things to improve:
You need the TableDef objects anyway, so you can directly loop them instead of AllTables
A table field cannot be Null, so this check isn't needed
For efficiency you want to only update rows where the column actually contains the searched character, so I add a WHERE clause
To avoid duplicate code, put all character codes to replace in an array for an additional loop.
Use db.Execute instead of DoCmd.RunSQL: it avoids the need for DoCmd.SetWarnings False, and gives you the number of affected records.
My suggestion:
Public Sub ReplaceCharAllTables()
Dim strSQL As String
Dim fld As DAO.Field
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim strFld As String
Dim arCharCodes As Variant
Dim code As Variant
' all charcodes to replace
arCharCodes = Array(10, 13)
Set db = CurrentDb()
' Cycle through all tables in database
For Each td In db.TableDefs
' Ignore system tables
If Not (td.Name Like "MSys*" Or td.Name Like "USys*") Then
' Cycle through all fields in the table
For Each fld In td.Fields
If fld.Type = dbText Then
For Each code In arCharCodes
strFld = "[" & fld.Name & "]"
strSQL = "UPDATE [" & td.Name & "] " & _
"SET " & strFld & " = Replace(" & strFld & ", Chr(" & code & "), '. ') " & _
"WHERE " & strFld & " LIKE '*" & Chr(code) & "*'"
Debug.Print strSQL
db.Execute strSQL
Debug.Print "Updated " & db.RecordsAffected & " records."
Next code
End If
Next fld
End If
Next td
End Sub
If this still gives errors, check the specific SQL (Ctrl+g shows the output of Debug.Print) - what column data type does it want to update?
I need to create an access (2007) table from a text file. I know ahead of time what columns should exist, but from time to time the vendors slip up and submit a text file that contains an incorrect number of columns. So I don't want to specify the columns in advance. I want to load all data as text into whatever columns exist. Then I will do QC.
The columns are pipe delimited and there are over 200 columns per record. There are no column headers, but there is one line of header text for the file, and one line at the end that states how many records there are. There may be anywhere from 1 to over 5,000 records in a text file. Records are identified with CRLF (windows).
Here is what I have so far, and it works (in that it reads the file and places the correct information in the recordset (columns and records), and I can count the number of records), except that the SELECT INTO gives me an error:
Sub OpenTextADO(strFileName As String, strPath As String)
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim fld As ADODB.Field
Dim recs As Integer
Dim strRecord As String
Dim strSQL As String
recs = 0
Set cn = New ADODB.Connection
If Right(strFileName, 3) = "txt" Then
'cn.Open "DRIVER={Microsoft Text Driver (*.txt; *.csv)};" & "DBQ=" & strPath & "\" 'need schema.ini file
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strPath & "\;Extended Properties='text;HDR=No;FMT=Delimited(|)'" 'need schema.ini file
End If
Set rs = New ADODB.Recordset
rs.Open "SELECT * INTO TESTTEXT FROM [" & strFileName & "]", cn, adOpenStatic, adLockOptimistic, adCmdText
'Do Until rs.EOF
' For Each fld In rs.Fields
' strRecord = strRecord & "|" & fld.Value
' Next fld
' strRecord = strRecord & vbCr
' recs = recs + 1
' rs.MoveNext
'Loop
'Debug.Print strRecord
'recs = rs.RecordCount
rs.Close
Set rs = Nothing
MsgBox "Text was opened and there are " & recs & " records in the table."
cn.Close
Set cn = Nothing
End Sub
NOTE: I included both the OLEDB version and the text driver version - they both seem to operate identically. I also created a schema.ini file that looks like this:
[test.txt]
Format=Delimited(|)
ColNameHeader=False
Both drivers seem to need this to desregard column headers, despite the "HDR=No" in the OLEDB version.
The error I get is: "Cannot update. Database or object is read-only".
I appreciate any help.
Could you do a sequential read of the text file, using the count of pipe-delimited fields in the first data line of the file to create a table with the proper number of columns, then just write subsequent lines into that table? I just threw the following together, but it seems to work.
Public Function import_txt_to_db(strFile As String) As Boolean
On Error GoTo ErrHandle
Dim strLine As String
Dim intFileNum As Integer
Dim blnFirstLine As Boolean
blnFirstLine = True
Dim varArray As Variant
intFileNum = FreeFile
Open strFile For Input Access Read As intFileNum
Do While Not EOF(intFileNum)
Line Input #intFileNum, strLine
varArray = Split(strLine, "|")
If blnFirstLine = True Then
'Use count of fields in first line to determine # of columns to create
Dim intColCount As Integer
intColCount = UBound(varArray)
Dim strQry As String
strQry = "CREATE TABLE tblImport ("
Dim intCtr As Integer
For intCtr = 1 To intColCount + 1
strQry = strQry & "[COLUMN_" & intCtr & "] TEXT(255),"
Next intCtr
strQry = Left(strQry, Len(strQry) - 1) & ")" 'get rid of terminal comma
CurrentDb.Execute strQry
blnFirstLine = False
End If
Dim strQry2 As String
strQry2 = "INSERT INTO tblImport VALUES('" & Replace(strLine, "|", "','") & "')"
CurrentDb.Execute strQry2
Loop
Close #intFileNum
import_txt_to_db = True
Exit Function
ErrHandle:
import_txt_to_db = False
End Function
I did a simple test with the folowing five-line text file
Thomas|Jefferson|Virginia
Bill|Clinton|Arkansas
Jimmy|Carter|Georgia
Lyndon|Johnson|Texas
George|Washington|Virginia
After running the code, here's my (simple) table: