Need Excel macro for exporting data to Access

[Guest]

Has someone written a macro to run in Excel that will append a fixed range of
data into an existing Access table. The data I need to exdport resides in
one sheet of a Excel file in list form with column headings. The files are
created by a piece of lab equipment each time a test is completed. Each
saved file shares a common structure but is given a unique file name. There
can be dozens of files created each day which makes use of the
TransferSpreadsheet function in Access impractical. The ideal macro would be
embedded in the Excel template file used to capture the test data.

 

[Guest]

This is infinitly do-able but it is not a great project for the first timer.
You need to be familiar with ADODB recordsets, SQL queries and to do this
right the whole thing should be stored as an XLA addin file. If you are
reasonably familiar with these concepts and only need a little help with the
implimentation then by all means reply back and I can feed you some code that
should help expedite this project...

HTH

 

[Guest]

The following is code that I got from Andy Wiggins some time ago and have
used, with some modification. You will have to adapt it to your setup. Hope
this helps you get started.


Option Explicit

'' ***************************************************************************
'' Purpose : Determine the current cell's format - return a SQL data type
'' Written : 19-Oct-1999 by Andy Wiggins - Byg Software Ltd
''
'' Commentary:
'' This function uses VBA's "VarType" to determine a cell's contents type.
'' The type is converted to a word that an MsAccess database will recognise.
''
Function fGetCellFormat(vAdd)

Dim vbFlag As Boolean
Dim x

''Extract from the Excel VBA Help file
''vbEmpty 0 Empty (uninitialized)
''vbNull 1 Null (no valid data)
''vbInteger 2 Integer
''vbLong 3 Long integer
''vbSingle 4 Single-precision floating-point number
''vbDouble 5 Double-precision floating-point number
''vbCurrency 6 Currency value
''vbDate 7 Date value
''vbString 8 String
''vbObject 9 Object
''vbError 10 Error value
''vbBoolean 11 Boolean value
''vbVariant 12 Variant (used only with arrays of variants)
''vbDataObject 13 A data access object
''vbDecimal 14 Decimal value
''vbByte 17 Byte value
''vbArray 8192 Array

Select Case VarType(vAdd)
Case 0, 1, 8, 10
x = "TEXT"

Case 2, 3, 4, 5, 14
x = "NUMBER"

Case 6
x = "CURRENCY"

Case 7
x = "DATETIME"

Case 11
x = "BIT"

Case Else ''Bucket
x = "TEXT"

End Select

fGetCellFormat = x

End Function



Option Explicit

'' ***************************************************************************
'' Purpose : Create a table from a range on a sheet
'' Written : 19-Oct-1999 by Andy Wiggins - Byg Software Ltd
''
Sub CreateTableAndAddData()
Dim cnn As New ADODB.Connection
Dim cmd As New ADODB.Command

Dim viCols%
Dim viRows%
Dim viCount%
Dim viRcount%
Dim vtWrapChar$
Dim vtSql$
Dim vtMessage$

'On Error GoTo ErrorHandler

ThisWorkbook.Activate

'' - - - - - - - - - - - - - - - - - - - - - - - - - - - -
'' Create a connection
cnn.Open DbConnection

'' - - - - - - - - - - - - - - - - - - - - - - - - - - - -
'' Go to the top left corner of the range
Application.GoTo reference:=Range("rtlData")

''Get some info about the range
With ActiveCell.CurrentRegion
viCols = .Columns.Count
viRows = .Rows.Count
End With

'' - - - - - - - - - - - - - - - - - - - - - - - - - - - -
'' Ensure the target table does not exist - careful, there's no recovery
'' if you delete a table that you wanted.
' On Error Resume Next
' vtSql = ""
' vtSql = vtSql & " DROP TABLE " & ctSheet

' cmd.CommandText = vtSql
' cmd.ActiveConnection = cnn
' cmd.Execute

On Error GoTo ErrorHandler

'' - - - - - - - - - - - - - - - - - - - - - - - - - - - -
'' Create the table
'' Go to the top left cell in the current range
' ActiveCell.CurrentRegion.Cells(1, 1).Select

' vtSql = ""
' vtSql = vtSql & " CREATE TABLE " & ctSheet & " ("

'' Loop around each column to create the SQL code
'' Column names must not contain spaces
' With ActiveCell.CurrentRegion
' For viCount = 1 To viCols
' vtSql = vtSql & .Cells(1, viCount) & "x " &
fGetCellFormat(.Cells(2, viCount))
' If viCount <> viCols Then
' vtSql = vtSql & ", "
' Else
' vtSql = vtSql & ")"
' End If
' Next
' End With

'' This has created the following SQL code ...

''CREATE TABLE DataSource
'' (Staff_Nox NUMBER,
'' Salaryx CURRENCY,
'' Namex TEXT,
'' Boolyx BIT,
'' Regionx NUMBER,
'' Datex DATETIME)

''.. which is exexcuted in the database
' cmd.CommandText = vtSql

' cmd.ActiveConnection = cnn

' cmd.Execute

'' Note: I have concatenated an "x" to the field name to try
'' and avoid reserved word conflicts in Access, e.g., if
'' a column was called "Date"

'' - - - - - - - - - - - - - - - - - - - - - - - - - - - -
'' Insert data into the table
With ActiveCell.CurrentRegion
For viRcount = 2 To viRows

vtSql = ""
vtSql = vtSql & " INSERT INTO " & ctSheet 'This is the db
Table Name
vtSql = vtSql & " VALUES ("

For viCount = 1 To viCols
Select Case fGetCellFormat(.Cells(2, viCount))
Case "TEXT"
vtWrapChar = """"
Case "DATETIME"
vtWrapChar = "#"
Case Else
vtWrapChar = ""
End Select

vtSql = vtSql & vtWrapChar & .Cells(viRcount, viCount) &
vtWrapChar

If viCount <> viCols Then
vtSql = vtSql & ","
Else
vtSql = vtSql & ")"
End If
Next

cmd.CommandText = vtSql

cmd.Execute
Next
End With

'' - - - - - - - - - - - - - - - - - - - - - - - - - - - -
'' Close and tidy up
lbTidy:
'' Close the connection
'' cnn.Close
Set cnn = Nothing
Set cmd = Nothing

Exit Sub

'' - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ErrorHandler:

vtMessage = "Table and data creation error"
vtMessage = vtMessage & _
Chr(10) & _
Chr(10) & "Error Number: " & Err & _
Chr(10) & "Error Description: " & Error()

MsgBox vtMessage, vbInformation, ctByg

Resume lbTidy

End Sub

 

[Jamie Collins]

The following is code that I got from Andy Wiggins some time ago

<snip>

That's a lot of code <g> (and anyhow doesn't do what the OP asked i.e.
creates a new table rather than inserting into an existing table). I
think this could be a job for 'ADO in just four lines':

Sub JustFourBygLines()
Dim con As Object
Set con = CreateObject("ADODB.Connection")
con.Open _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\MyJetDB.mdb"
con.Execute _
"INSERT INTO MyNewtable (MyCol1, MyCol2, MyCol2)" & _
" SELECT MyCol1, MyCol2, MyCol3 FROM" & _
" [Excel 8.0;HDR=YES;Database=C:\MyWorkbook;].MyRange;"
End Sub

Jamie.

--

 

[Guest]

Jamie,
Thanks for the concise update.
Rather than hardcode it as you have, I would like to make it generic by
adding variables to the code. Below is the code I have tried with comments
to describe my setup and possible changes I need to make in order for it to
work.
The execute command is yielding an error as the code exists below, so it
needs a little tweaking. Can you advise on where to make the adjustments?

Also, will this work if MyRange has only a subset of the db Fields? e. g. if
the mdb had 10 fields and MyRange showed only Field1, Field4 and Field7

Much appreciated

The following is code that I got from Andy Wiggins some time ago

<snip>

That's a lot of code <g> (and anyhow doesn't do what the OP asked i.e.
creates a new table rather than inserting into an existing table). I
think this could be a job for 'ADO in just four lines':

Sub JustFourBygLines()
Dim con As Object
Set con = CreateObject("ADODB.Connection")
con.Open _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\MyJetDB.mdb"
con.Execute _
"INSERT INTO MyNewtable (MyCol1, MyCol2, MyCol2)" & _
" SELECT MyCol1, MyCol2, MyCol3 FROM" & _
" [Excel 8.0;HDR=YES;Database=C:\MyWorkbook;].MyRange;"
End Sub

Jamie.

 

[Guest]

sorry I forgot the code:

Option Explicit

Sub AddRecordsToDB()

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Setup:
'Access: An MS Access file: NewTestDB.mdb in same folder as This Excel
Workbook
' The mdb has one Table: MyTable
' This table has 3 Fields: Staff_Num, Salary, LastName
'Excel: On Sheet1:
' Range("A1:A100") is named MyRange
' Range("A1") is named MyCol1 value: Staff_Num
' Range("B1") is named MyCol2 value: Salary
' Range("C1") is named MyCol3 value: LastName
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim con As Object
Dim sPath As String
Dim sDbFile As String
Dim sMyTable As String
Dim MyCol1, MyCol2, MyCol3
Dim sThisWbk As String
Dim sBkName As String
Dim Rng1 As Range


sBkName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
sPath = ThisWorkbook.Path
sThisWbk = sPath & "\" & sBkName

sDbFile = sPath & "\NewTestDB.mdb"
sMyTable = "MyDbTable"

'Get Field names
MyCol1 = Range("MyCol1").Value 'Field names only-no data ????
MyCol2 = Range("MyCol2").Value
MyCol3 = Range("MyCol3").Value
''''Perhaps the above ranges should include data ????????

'Locate MyRange in Excel (A1:C100)
'This has both data and Field name headers
'which match the .mdb table fields
''''''''''''''''''''''
'This perhaps should exclude headers ?????
'and start with row 2 ????????
''''''''''''''''''
Set Rng1 = Range("MyRange")

Set con = CreateObject("ADODB.Connection")

con.Open _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sDbFile & ""

con.Execute _
"INSERT INTO " & sMyTable & " (" & MyCol1 & "," & MyCol2 & "," & MyCol3
& "," & MyCol4 & "," & MyCol5 & "," & MyCol6 & ")" & _
" SELECT " & MyCol1 & "," & MyCol2 & "," & MyCol3 & "," & MyCol4 & "," &
MyCol5 & "," & MyCol6 & " FROM" & _
" [Excel 8.0;HDR=YES;Database=" & ThisWbk & ";]." & Rng1 & ";"

''''''' Perhaps the above Excel 8.0 is not correct for my Excel 2000
???????
End Sub

The following is code that I got from Andy Wiggins some time ago

<snip>

That's a lot of code <g> (and anyhow doesn't do what the OP asked i.e.
creates a new table rather than inserting into an existing table). I
think this could be a job for 'ADO in just four lines':

Sub JustFourBygLines()
Dim con As Object
Set con = CreateObject("ADODB.Connection")
con.Open _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\MyJetDB.mdb"
con.Execute _
"INSERT INTO MyNewtable (MyCol1, MyCol2, MyCol2)" & _
" SELECT MyCol1, MyCol2, MyCol3 FROM" & _
" [Excel 8.0;HDR=YES;Database=C:\MyWorkbook;].MyRange;"
End Sub

Jamie.

 

[Guest]

Okay, I've tweaked it an got it working just fine.
It also works with a subset of fields from the db as long
as there are no blank colums in MyRange.

Here's the code:



Option Explicit

Sub AddRecordsToDB()

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Setup:
'Access: An MS Access file: NewTestDB.mdb in same folder as This Excel
Workbook
' The mdb has one Table: MyTable
' This table has 3 Fields: Staff_Num, Salary, LastName
'Excel: On Sheet1:
' Range("A1:C100") is initially named MyRange
' Range("A1") is named Field1 value: Staff_Num
' Range("B1") is named Field2 value: Salary
' Range("C1") is named Field3 value: LastName
' Leave Blanks around MyRange
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim con As Object
Dim sPath As String
Dim sDbFile As String
Dim sDbTable As String
Dim Fld1, Fld2, Fld3
Dim sThisWbk As String
Dim sWbkName As String
Dim Sql As String


sWbkName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
sPath = ThisWorkbook.Path
sThisWbk = sPath & "\" & sWbkName

'Enter the Database name and Table Names
'Adjust as needed
sDbFile = sPath & "\NewTestDB.mdb"
sDbTable = "MyDbTable"

'Get Field names
Fld1 = Range("Field1")
Fld2 = Range("Field2")
Fld3 = Range("Field3")


'To avoid adding blank records in the db:
'Resize MyRange in Excel to include only the records
'---no blank rows
'This has both data and Field Name headers
'which match the .mdb table fields
ActiveWorkbook.Names.Add Name:="MyRange", _
RefersTo:=Range("MyRange").Resize _
(Range("MyRange").CurrentRegion.Rows.Count, _
Range("MyRange").CurrentRegion.Columns.Count)

Set con = CreateObject("ADODB.Connection")

con.Open _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sDbFile & ""

Sql = "INSERT INTO " & sDbTable & "(" & Fld1 & "," & Fld2 & "," & Fld3 &
")" & _
" SELECT " & Fld1 & "," & Fld2 & "," & Fld3 & " FROM" & _
" [Excel 8.0;HDR=YES;Database=" & sThisWbk & ";].MyRange;"

con.Execute Sql

MsgBox "Records Added: " & Range("MyRange").Rows.Count - 1, vbOKOnly, ""

End Sub

The following is code that I got from Andy Wiggins some time ago

<snip>

That's a lot of code <g> (and anyhow doesn't do what the OP asked i.e.
creates a new table rather than inserting into an existing table). I
think this could be a job for 'ADO in just four lines':

Sub JustFourBygLines()
Dim con As Object
Set con = CreateObject("ADODB.Connection")
con.Open _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\MyJetDB.mdb"
con.Execute _
"INSERT INTO MyNewtable (MyCol1, MyCol2, MyCol2)" & _
" SELECT MyCol1, MyCol2, MyCol3 FROM" & _
" [Excel 8.0;HDR=YES;Database=C:\MyWorkbook;].MyRange;"
End Sub

Jamie.