VBA import all files in folder to Access - excel

the goal is to import all excel files in one folder to seperate sheets in access. I found this script and didnt know where to ask instead
Dim blnHasFieldNames as Boolean
Dim strWorksheet As String, strTable As String
Dim strPath As String, strPathFile As String
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = False
' Replace C:\Documents\ with the real path to the folder that
' contains the EXCEL files
strPath = "C:\Documents\"
' Replace worksheetname with the real name of the worksheet that is to be
' imported from each file
strWorksheet = "worksheetname"
' Import the data from each workbook file in the folder
strFile = Dir(strPath & "*.xls")
Do While Len(strFile) > 0
strPathFile = strPath & strFile
strTable = "tbl_" & Left(strFile, InStrRev(strFile, ".xls") - 1)
DoCmd.TransferSpreadsheet acImport, _
acSpreadsheetTypeExcel9, strTable, strPathFile, _
blnHasFieldNames, strWorksheet & "$"
' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile
strFile = Dir()
Loop
here: http://www.accessmvp.com/KDSnell/EXCEL_Import.htm#ImpWktFilesSepTbls
I dont get how to use the code(turn it into a macro?) also is it possible to grab the 3rd row eg and take it as header ? Do you know where I can finde information about it ?
Thanks

You could export data from Excel to Access, and start on a specific row.
Sub ADOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=C:\FolderName\DataBaseName.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "TableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 3 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("FieldName1") = Range("A" & r).Value
.Fields("FieldName2") = Range("B" & r).Value
.Fields("FieldNameN") = Range("C" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
Or, import everything like you are doing now, and run a small delete query on the table after doing the import.
Something like...Delete * from Table Where Field1 is "", or whatever.
The next effect is exactly the same.

Related

Excel to Access VBA Loop

I am trying to write some code that uses an excel template to upload data to an access DB. I'm somewhat new to VB so I got the code offline and tailored it to my needs. When I try to run it I am receiving a "Compile error: Do without loop" error message. Please advise as to what I am doing wrong.
All help is greatly appreciated!
Sub UploadtoAccess()
'
' UploadtoAccess Macro
'
'Sub ADOFromExcelToAccess()'
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "provider = microsoft.ace.oledb.12.0;" & _
"Data Source=C:\Users\filepath (full file path taken out)
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "Expenses", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 2 ' the start row in the worksheet
Do While Len(Range(“A” & r).Formula) > 0
Do While Len(Range(“B” & r).Formula) > 0
Do While Len(Range(“C” & r).Formula) > 0
Do While Len(Range(“D” & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("Expense_Type_ID") = Range("A" & r).Value
.Fields("Expense_Type") = Range(“B” & r).Value
.Fields(“Expense_Month”) = Range(“C” & r).Value
.Fields(“Expense_Amount”) = Range(“D” & r).Value
' add more fields if necessary…
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub

Send data from excel to access, run queries, send query results back to excel

So basically I would like to be able to send date from excel to access, run some queries, and send the results back to excel, and do this all from excel VBA.
I would like to send my data, which is in an excel worksheet with sheet name "Enrollment Data Aggregate" to an access database H:\My file extension\Nameofdatabase.accdb and save it as a table with the name "Enrollment Data Aggregate".
I already have queries put together that run from the table "Enrollment Data Aggregate", so I think (hope) that I can delete that table, and when I pull in the new one from excel, the queries will still update. Then I would like access to run/update the queries and export them as separate tabs to my excel file.
Ideally, I would then like to continue doing other things in excel VBA. In other words, I'm really hoping that I can control all of this from excel. I have plenty of experience with excel and access, but I've only done about 4 VBA projects that were large like this (I've done lots of small macros) so I'm not super experienced. Any suggestions would be greatly appreciated.
To export data from Excel to Access:
Sub ADOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=C:\FolderName\DataBaseName.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "TableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 3 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("FieldName1") = Range("A" & r).Value
.Fields("FieldName2") = Range("B" & r).Value
.Fields("FieldNameN") = Range("C" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
To import data from Access to Excel:
Sub ADOImportFromAccessTable(DBFullName As String, _
TableName As String, TargetRange As Range)
' Example: ADOImportFromAccessTable "C:\FolderName\DataBaseName.mdb", _
"TableName", Range("C1")
Dim cn As ADODB.Connection, rs As ADODB.Recordset, intColIndex As Integer
Set TargetRange = TargetRange.Cells(1, 1)
' open the database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
DBFullName & ";"
Set rs = New ADODB.Recordset
With rs
' open the recordset
.Open TableName, cn, adOpenStatic, adLockOptimistic, adCmdTable
' all records
'.Open "SELECT * FROM " & TableName & _
" WHERE [FieldName] = 'MyCriteria'", cn, , , adCmdText
' filter records
RS2WS rs, TargetRange ' write data from the recordset to the worksheet
' ' optional approach for Excel 2000 or later (RS2WS is not necessary)
' For intColIndex = 0 To rs.Fields.Count - 1 ' the field names
' TargetRange.Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
' Next
' TargetRange.Offset(1, 0).CopyFromRecordset rs ' the recordset data
End With
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
Running an Access Query from Excel:
Sub CreateAndRunQuery()
'------------------------------------------------------------------------------------------
'This macro opens the Sample.accdb database, creates and runs an SQL query (filtering
'all the customers from Canada). Then, it copies selected fields back in the Excel sheet.
'The code uses late binding, so no reference to external library is required.
'Written By: Christos Samaras
'Date: 05/10/2013
'Last Updated: 29/11/2014
'E-mail: xristos.samaras#gmail.com
'Site: http://www.myengineeringworld.net
'------------------------------------------------------------------------------------------
'Declaring the necessary variables.
Dim con As Object
Dim rs As Object
Dim AccessFile As String
Dim strTable As String
Dim SQL As String
Dim i As Integer
'Disable screen flickering.
Application.ScreenUpdating = False
'Specify the file path of the accdb file. You can also use the full path of the file like:
'AccessFile = "C:\Users\Christos\Desktop\Sample.accdb"
AccessFile = ThisWorkbook.Path & "\" & "Sample.accdb"
'Set the name of the table you want to retrieve the data.
strTable = "Customers"
On Error Resume Next
'Create the ADODB connection object.
Set con = CreateObject("ADODB.connection")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection Error"
Exit Sub
End If
On Error GoTo 0
'Open the connection.
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
'Create the SQL statement to retrieve the data from table.
'Get the necessary information (first name etc.) for all the Canadian customers.
SQL = "SELECT FirstName, LastName, Address, City, Phone FROM " & strTable & " WHERE COUNTRY='Canada'"
On Error Resume Next
'Create the ADODB recordset object.
Set rs = CreateObject("ADODB.Recordset")
'Check if the object was created.
If Err.Number <> 0 Then
'Error! Release the objects and exit.
Set rs = Nothing
Set con = Nothing
'Display an error message to the user.
MsgBox "Recordset was not created!", vbCritical, "Recordset Error"
Exit Sub
End If
On Error GoTo 0
'Set thee cursor location.
rs.CursorLocation = 3 'adUseClient on early binding
rs.CursorType = 1 'adOpenKeyset on early binding
'Open the recordset.
rs.Open SQL, con
'Check if the recordet is empty.
If rs.EOF And rs.BOF Then
'Close the recordet and the connection.
rs.Close
con.Close
'Release the objects.
Set rs = Nothing
Set con = Nothing
'Enable the screen.
Application.ScreenUpdating = True
'In case of an empty recordset display an error.
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
'Copy the recordset headers.
For i = 0 To rs.Fields.Count - 1
Sheets("New Query").Cells(1, i + 1) = rs.Fields(i).Name
Next i
'Write the query values in the sheet.
Sheets("New Query").Range("A2").CopyFromRecordset rs
'Close the recordet and the connection.
rs.Close
con.Close
'Release the objects.
Set rs = Nothing
Set con = Nothing
'Adjust the columns' width.
Sheets("New Query").Columns("A:E").AutoFit
'Enable the screen.
Application.ScreenUpdating = True
'Inform the user that the macro was executed successfully.
MsgBox "The Canadian customers were successfully retrieved from the '" & strTable & "' table!", vbInformation, "Done"
End Sub
You will find more info here.
http://www.myengineeringworld.net/2013/10/running-access-queries-from-excel-vba.html

How to delete rows from excel files if a cell in a particular column contains the string of array?

I have many excel files in many folders and I need to delete the rows from all files where in column for ex. B are words from array:
For ex. my bad words list:
the sun, tree, big car, cup, ....
If A2 column is 'The Sun is the star at the center of the Solar System.' - this row has been deleted.
If in column is 'thesunis the..' - this row has been deleted. But is bad!
And my questions:
How to delete rows with exact words of array element?
How to count array elements?
How to escape single quote in array element (example in code below)
How to open all files from folder "C://folder" and after run code save all?
Here is my code:
Sub code()
Dim MyValue As String
Dim a As Integer
'------------------------------------------------------
ArrayValueToRemove = Array("the sun", "code 'in", "another")
Range("B:B").Select
'------------------------------------------------------
For Each cell In Selection
MyValue = CStr(cell.Value)
For a = 0 To 2
If InStr(1, LCase(MyValue), LCase(ArrayValueToRemove(a))) > 0 Then
cell.EntireRow.Delete
Exit For
End If
Next
Next cell
End Sub
Sub deleteBadWordRows()
Dim currentFile, currentSheet, badWords As Variant, lastRow, i As Integer, baseDirectory As String
'------------------------------------------------------
baseDirectory = "c:\folder\"
badWords = Array("the sun", "code 'in", "another")
'------------------------------------------------------
currentFile = Dir(baseDirectory)
While (currentFile <> "")
Workbooks.Open baseDirectory + currentFile
For Each currentSheet In Workbooks(currentFile).Worksheets
lastRow = currentSheet.Cells(currentSheet.Rows.Count, "B").End(xlUp).Row
For j = 1 To lastRow
For i = 0 To UBound(badWords)
If InStr(1, LCase(CStr(currentSheet.Cells(j, "B").Value)), LCase(badWords(i))) > 0 Then
currentSheet.Rows(j).Delete
j = j - 1
lastRow = lastRow - 1
Exit For
End If
Next
Next
Next
Workbooks(currentFile).Save
Workbooks(currentFile).Close
currentFile = Dir
Wend
End Sub
Consider an SQL solution to query your string searches using the LIKE operator with wildcard, %. Excel for PC can connect to the Jet/ACE SQL Engine (Window .dll files) and query workbooks. Here you avoid the nested looping except for iterating through workbooks.
Below assumes all worksheets are tabular in structure with column headers all beginning at A1. Query results are dumped to a new worksheet where you can delete current worksheet afterwards. Be sure to replace placeholders with actual names, CurrentWorksheet, ColumnA, NewWorksheet:
Sub DeleteSQL()
Dim conn As Object, rst As Object
Dim strConnection As String, strSQL As String
Dim i As Integer
Dim wb As Workbook
Dim dirpath As String: dirpath = "C:\\Folder"
Dim xlfile As Variant: xlfile = Dir(dirpath & "\*.xls*")
Do While (xlfile <> "")
Set wb = Workbooks.Open(dirpath & "\" & xlfile)
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
' WORKBOOK CONNECTION
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source='" & dirpath & "\" & xlfile & "';" _
& "Extended Properties=""Excel 8.0;HDR=YES;"";"
' OPEN DB CONNECTION
conn.Open strConnection
' OPEN RECORDSET
strSQL = " SELECT * FROM [CurrentWorksheet$]" _
& " WHERE [ColumnA] LIKE ""%the sun%"" OR [ColumnA]" _
& " LIKE ""%code 'in%"" OR [ColumnA] LIKE ""%another%"""
rst.Open strSQL, conn
wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count).Name = "NewWorkSheet"
' RESULTSET COLUMNS
For i = 1 To rst.Fields.Count
wb.Worksheets("NewWorkSheet").Cells(1, i) = rst.Fields(i - 1).Name
Next i
' RESULTSET DATA ROWS
wb.Worksheets("NewWorkSheet").Range("A2").CopyFromRecordset rst
wb.Close True
rst.Close: conn.Close
Set rst = Nothing: Set conn = Nothing
xlfile = Dir
Loop
End Sub

VBA import two txt files in the same workbook

Is there a way to import two txt files in the same workbook?
I can import one txt file easily with
ActiveSheet.QueryTables.Add(Connection:= _
However whenever I add another it just ignores the first txt file.
Many thanks
Does it ignore the first text file or does it overwrite it if ActiveSheet doesn't change?
You could explicitly specify the Sheet(s) before the .Add method(s) or, if you wanted both imports on the same sheet, there is a Destination:= parameter which allows you to specify a starting Range. A reference can be found here.
If you want to load both Text Files in the same sheet, you can try using ADO.
Something like:
Sub conscious()
Dim con As ADODB.Connection, rec As ADODB.Recordset
Set con = New ADODB.Connection: Set rec = New ADODB.Recordset
Dim datasource As String, txtfiles As Variant _
, txt1 As String, txt2 As String
txtfiles = Application.GetOpenFilename(FileFilter:="CSV Files, *.csv", _
MultiSelect:=True)
datasource = Left(txtfiles(1), InStrRev(txtfiles(1), "\"))
txt1 = "[" & Dir(txtfiles(1)) & "]"
txt2 = "[" & Dir(txtfiles(2)) & "]"
Dim sconnect As String
sconnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & datasource & _
";Extended Properties=""Text;HDR=YES;FMT=Delimited(,)"";"
con.Open sconnect
Dim sqlstr As String
sqlstr = "SELECT * FROM " & txt1 & _
"UNION ALL SELECT * FROM " & txt2
rec.Open sqlstr, con, adOpenStatic, adLockReadOnly
With Sheets("Sheet1")
Dim lrow As Long
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
If lrow > 1 Then .Range("A2:J" & lrow).ClearContents
.Range("A2").CopyFromRecordset rec
End With
Application.ScreenUpdating = True
rec.Close: con.Close
Set rec = Nothing: Set con = Nothing
End Sub
Basically this prompts you to select files.
I used a CSV file as sample. Adjust to suit.
You can select as many files, but this handles the first 2 files only.
If you need to handle more, you'll have to loop through the selected files. HTH

Exporting each Excel column to individual text or csv files?

I have an Excel worksheet with around 100 cols. Does anyone know of an easy way to write the contents of each column to a csv or txt file?
I don't have Excel in front of me, but I think this code is approximately what you need, give or take some syntax errors. It should write each column into a separate file, with each cell on a different row. It will work for arbitrary column heights, though the number of columns is in a variable (for now).
dim fso as FileSystemObject
dim ts as TextStream
dim i as Integer
dim myCell as Range
set fso = FileSystemObject
for i = 0 to TotalColumnNumber
' last argument, True, says to create the text file if it doesnt exist, which is
' good for us in this case
Set ts = fso.OpenTextFile("column_" & i, ForWriting, True)
' set mycell to the first cell in the ith column
set myCell = SheetName.cells(1,i)
' continue looping down the column until you reach a blank cell
' writing each cell value as you go
do until mycell.value = ""
ts.writeline mycell.value
set myCell = myCell.offset(1,0)
loop
ts.close
next
set ts = nothing
set fso = nothing
Let me know if that helps or not, I can take another look later if you would like
Perhaps
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim i As Integer
''This is not the best way to refer to the workbook
''you want, but it is very conveient for notes
''It is probably best to use the name of the workbook.
strFile = ActiveWorkbook.FullName
''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''This is the Jet 4 connection string, you can get more
''here : http://www.connectionstrings.com/excel
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
''WHERE 1=1 = headers only, note hdr=yes above
strSQL = "SELECT * " _
& "FROM [Sheet1$] " _
& "WHERE 1=1"
''Open the recordset for more processing
''Cursor Type: 3, adOpenStatic
''Lock Type: 3, adLockOptimistic
''Not everything can be done with every cirsor type and
''lock type. See http://www.w3schools.com/ado/met_rs_open.asp
rs.Open strSQL, cn, 3, 3
''Output including nulls. Note that this will fail if the file
''exists.
For i = 0 To rs.Fields.Count - 1
strSQL = "SELECT [" & rs.Fields(i).Name & "] " _
& "INTO [Text;HDR=YES;FMT=Delimited;IMEX=2;DATABASE=C:\Docs\]." _
& rs.Fields(i).Name & ".CSV " _
& "FROM [Sheet1$] "
''To skip nulls and empty cells, add a WHERE statement
''& "WHERE Trim([" & rs.Fields(i).Name & "] & '')<>'' "
cn.Execute strSQL
Next
''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
A very quick line to get you started ...
for i = 1 to 100
open "file" & i & ".txt" as #1
for each c in columns(i).cells
print #1, c.value
next c
close #1
next i

Resources