VBA Macro to export data from Excel to Access

elcorazon

New Member
Joined
Sep 28, 2008
Messages
5
Hi,

Having thoroughly (I think) searched the internet for solutions I'm thoroughly stumped.

I'm using Excel 2003 and Access 2003

I have a VBA Macro that selects, trims and then copies a range of data in my spreadsheet. It then creates a new database named according to the value in cell C2 in the spreadsheet. What I am ultimately trying to do is then insert/paste the copied data into a new table (called SURVEY) in the newly created Access database.

I can get, as you will see, the newly created Access database open but when I manually paste the data in (Edit>Paste), I don't get the option 'Does the first row of your data contain column headings?', which my data does not and the data then pastes into the new table incorrectly. If I have to manually paste the data, I have to close access down and re-open it before I get that option.

My knowledge of VBA / Macros is limited; I'm taking a 'throw myself in the deep end and feel my way around' approach but will apply myself to learning the ins and outs of any solutions proposed.

Desired outcomes: One of two :-
Either - the last bit of code to automatically insert the selected data into a new Access table
Or - A way of ensuring that my manually pasted data isn't treated as if the first row contains column headings.

Code I am using:
(disclaimer: I've written very little of this myself, the majority is cannibalised from the results of my internet searches)

Code:
Sub InsertInto()
    Dim dbConnectStr As String
    Dim Catalog As Object
    Dim cnt As ADODB.Connection
    Dim dbPath As String
    
    For Each CELL In [B1:C360]
    CELL.Value = WorksheetFunction.Trim(CELL)
    Next CELL
    
    Range("A1:I360").Select
    Selection.Copy
    'Set database name here
    dbPath = "D:\Uploaded\" & Range("C2") & ".mdb"
    dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath & ";"
    'Create new database
    Set Catalog = CreateObject("ADOX.Catalog")
    Catalog.Create dbConnectStr
    Set Catalog = Nothing
    'Open Access and make visible
    Set oApp = CreateObject("Access.Application")
    oApp.Visible = True
    'Open Access database as defined by LPath variable
    oApp.OpenCurrentDatabase dbPath
End Sub

Thank you in advance for any help you're able to give.
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Hi,
What keeps you from using an existing database or table? I only ask because its very easy to simply:

1) Open Access
2) Run a query to truncate the table (delete all records but leave the fields)
3) import new data with File | Get External Data | Import...

Anyway, for more info you can see Fazza's post Creating a Database on the Fly. Another option would be to use an ADO command object to update the table with your data, which is pretty easy once you get the hang of it (after you have your table created, of course).

Edit: Also see Creating an Acess database with VBA and SQL - this URL is noted in Fazza's post above.
 
Last edited:
Upvote 0
Hi,
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p> </o:p>
Thanks for your helpful advice. I’ve used the excel guru site in the compilation of what code I already had but Fazza’s post made good reading, albeit some of it is a bit beyond me.
<o:p> </o:p>
My approach is process driven. Each spreadsheet contains the variable that determine the database name and each spreadsheet has to be saved as an individual database with a unique name (in this case a property reference number) in order for the data to be uploaded to a web-based database (I have no control over this bit). The process is as follows:
<o:p> </o:p>
A) Users A, B, C etc enter survey data for a property into a spreadsheet. Each set of data is saved as a separate spreadsheet (PropertyRef.xls)<o:p></o:p>
B) Rinse and repeat several hundred times<o:p></o:p>
C) I then take the spreadsheets, create PropertyRef.mdb for each one and paste the survey data (in a sheet called SURVEY) into each database as a table called SURVEY (no column headers). <o:p></o:p>
<o:p> </o:p>
Having done some more reading and testing my code now looks like this:
<o:p> </o:p>
Code:
[COLOR=black][FONT=Verdana]Sub InsertInto()<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]<o:p> </o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Dim dbConnectStr As String<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Dim Catalog As Object<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Dim cnt As ADODB.Connection<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Dim dbPath As String<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]   <o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]   [/FONT][/COLOR][COLOR=black][FONT=Verdana] For Each CELL In [A1:C360]<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    CELL.Value = WorksheetFunction.Trim(CELL)<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Next CELL<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    <o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    'Set database name here<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    dbPath = "D:\Uploaded\" & Range("C2") & ".mdb"<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath & ";"<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]<o:p> </o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]<o:p> </o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    'Create new database<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Set Catalog = CreateObject("ADOX.Catalog")<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Catalog.Create dbConnectStr<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Set Catalog = Nothing<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    <o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]        <o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    'Connect to database and insert a new table<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Set cnt = New ADODB.Connection<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    With cnt<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]        .Open dbConnectStr<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]        .Execute "CREATE TABLE SURVEY ([F1] text(150) WITH Compression, " & _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]                 "[F2] text(150) WITH Compression, " & _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]                 "[F3] text(150) WITH Compression, " & _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]                 "[F4] text(150) WITH Compression, " & _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]                 "[F5] text(150) WITH Compression, " & _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]                 "[F6] text (150)WITH Compression, " & _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]                 "[F7] text (150)WITH Compression, " & _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]                 "[F8] text (150)WITH Compression, " & _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]                 "[F9] text (150)WITH Compression )"<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]            <o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    End With<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Set cnt = Nothing<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    <o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]<o:p> </o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    sPath = "C:\Documents and Settings\CATM2567\Desktop\Done\" & Range("C2") & ".xls"<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    ActiveWorkbook.SaveAs sPath<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    <o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Range("A1:I360").Select<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]    Selection.Copy<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]<o:p> </o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Verdana]End Sub[/FONT][/COLOR]
<o:p> </o:p>
I think this inserts an appropriately defined table. My data has no column headers so I have used the default F1, F2 etc, however each time I try to define my range to use with the INSERT INTO command it fails.
<o:p> </o:p>
I’m using:
<o:p> </o:p>
Code:
    Dim wbBook As Workbook 
    Dim wsData As Worksheet
    Dim rngDB As Range
<o:p> </o:p>
    Set wbBook = ThisWorkbook 
    Set wsData = wbBook.Worksheets("SURVEY") 
     
    With wsData 
        Set rngDB = .Range("$A1:$I360") 
    End With
<o:p> </o:p>
But I get a ‘Runtime Error 9: Subscript out of range’ for wsData. I have checked and re-checked and the sheet I want is called SURVEY.

Thanks once again for your time.
 
Upvote 0
There is a known bug when it comes to copying and saving hundreds of sheets in the same workbook...could this be the problem? The error message doesn't appear to match, but you should probably know about this one anyway. The code looks right. Let me know if this applies:

http://support.microsoft.com/kb/210684/en-us
 
Upvote 0
Hi,

It doesn't apply in this case, however, the good news is I think I've found a workaround. The bad news is, as seems to be the case too much in this little project, I've hit another stumbling block, hopefully the last one!

My code is now:

Code:
Sub Database()

    Dim dbConnectStr As String
    Dim Catalog As Object
    Dim cnt As ADODB.Connection
    Dim dbPath As String
    Dim strSQL As String
    Dim rngDB As Range
    Dim wbPath As String
    Dim stSQL As String
        

    wbPath = "ThisWorkbook.Fullname"
    
    For Each CELL In [B1:C360]
    CELL.Value = WorksheetFunction.Trim(CELL)
    Next CELL
    

    'Set database name here
    dbPath = "C:\Documents and Settings\Xander\Desktop\Uploaded\" & Range("C2") & ".mdb"
    dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath & ";"
    
    'Create new database
    Set Catalog = CreateObject("ADOX.Catalog")
    Catalog.Create dbConnectStr
    'Set Catalog = Nothing
  
    stSQL = "INSERT INTO SURVEY SELECT * FROM [SURVEY$A1:I360] IN '" _
    & wbPath & "' 'Excel 8.0;HDR=No;'"
   
    'Connect to database and insert a new table
    Set cnt = New ADODB.Connection
    With cnt
        .Open dbConnectStr
        .Execute "CREATE TABLE SURVEY ([F1] text(150) WITH Compression, " & _
                 "[F2] text(150) WITH Compression, " & _
                 "[F3] text(150) WITH Compression, " & _
                 "[F4] text(150) WITH Compression, " & _
                 "[F5] text(150) WITH Compression, " & _
                 "[F6] text (150)WITH Compression, " & _
                 "[F7] text (150)WITH Compression, " & _
                 "[F8] text (150)WITH Compression, " & _
                 "[F9] text (150)WITH Compression )"
                 
        .Execute stSQL
    
    End With
    Set cnt = Nothing
    
    

    sPath = "C:\Documents and Settings\Xander\Desktop\Done\" & Range("C2") & ".xls"
    ActiveWorkbook.SaveAs sPath
    
    Range("A1:I360").Select
    Selection.Copy

This now returns an "80040e09 - Cannot Update. Database or object is read-only" error. I've done some more reading around it, including http://www.ozgrid.com/forum/showthread.php?t=44667 but can't come up with a reason for the error or a solution.

Getting there slowly but surely.

Once again, thanks for the help.
 
Upvote 0
Hmmm.

Well, I can report that it works for me. One thing that looks funny is:
Code:
wbPath = "ThisWorkbook.FullName"

Normally, code along these lines is:

Code:
wbPath = ThisWorkbook.FullName 'No Quotes

------------
You might just check your Access application settings under Tools | Options on the general tab and make sure that the default open mode is "shared". I have no idea if this would affect databases created in code but maybe that's the problem - the database may be opened in Exclusive mode (although of course we just created it...and it should be "ours" so this is a long shot).

--AB

Let me know if that helps. Of course, step through the code with F8 (executes one line at a time) and Ctrl + F8 (Executes to cursor) - to check your variables as your proceed (typing ?VariableName in the immediate window etc.
 
Last edited:
Upvote 0
FYI perhaps a little cleaner to close your connection this way:

Code:
If (cnt.State = ObjectStateEnum.adStateOpen) Then
    cnt.Close
End If
Set cnt = Nothing

Is the error reported in your last post happening on the first database you create - the first run through?
 
Upvote 0
Success! Thank you so much for your help.

The runtime error was because the folder into which the database was being written was Read Only and windows wouldn't let me manually remove this setting. I used setAttr to work round that.

My final code is this:

(Please ignore the commented out duplications, they are there to provide a roll-back function if needs be.)

Rich (BB code):
Sub Database()
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
   Dim dbConnectStr As String
   Dim Catalog As Object
   Dim cnt As ADODB.Connection
   Dim dbPath As String
   Dim strSQL As String
   Dim rngDB As Range
   Dim wbPath As String
   Dim stSQL As String
 
<o:p></o:p>
   'wbPath = "ThisWorkbook.Fullname"
 
   'For Each CELL In [B1:C360]
   'CELL.Value = WorksheetFunction.Trim(CELL)
   'Next CELL
 
<o:p></o:p>
   'Set database name here
   dbPath = "D:\Uploaded\" & Range("C2") & ".mdb"
   dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath & ";"
 
   'Create new database
   Set Catalog = CreateObject("ADOX.Catalog")
   Catalog.Create dbConnectStr
   'Set Catalog = Nothing
 
   'stSQL = "INSERT INTO SURVEY SELECT * FROM [SURVEY$A1:I360] IN '" _
   '& wbPath & "' 'Excel 8.0;HDR=No;'"
 
   'Connect to database and insert a new table
   Set cnt = New ADODB.Connection
   With cnt
       .Open dbConnectStr
       .Execute "CREATE TABLE SURVEY ([F1] text(150) WITH Compression, " & _
                "[F2] text(150) WITH Compression, " & _
                "[F3] text(150) WITH Compression, " & _
                "[F4] text(150) WITH Compression, " & _
                "[F5] text(150) WITH Compression, " & _
                "[F6] text (150)WITH Compression, " & _
                "[F7] text (150)WITH Compression, " & _
                "[F8] text (150)WITH Compression, " & _
                "[F9] Decimal(3))"
 
   '    .Execute stSQL
 
   End With
   Set cnt = Nothing
 
 
<o:p></o:p>
   'sPath = "C:\Documents and Settings\CATM2567\Desktop\Done\" & Range("C2") & ".xls"
   'ActiveWorkbook.SaveAs sPath
 
   Call PasteData
 
   'Range("A1:I360").Select
   'Selection.Copy
 
<o:p></o:p>
End Sub
<o:p></o:p>
 
<o:p></o:p>
Sub PasteData()
<o:p></o:p>
   Dim dbConnectStr As String
   Dim cnt As ADODB.Connection
   Dim dbPath As String
   Dim strSQL As String
   Dim rngDB As Range
   Dim wbPath As String
   Dim stSQL As String
   Dim rtPath As String
 
   rtPath = "D:\Uploaded\"
 
   SetAttr rtPath, vbNormal
<o:p></o:p>
   wbPath = ActiveWorkbook.FullName
 
 
   For Each CELL In [B1:C360]
   CELL.Value = WorksheetFunction.Trim(CELL)
   Next CELL
 
<o:p></o:p>
   'Set database name here
   dbPath = "D:\Uploaded\" & Range("C2") & ".mdb"
   dbConnectStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath & ";"
 
 
 
   stSQL = "INSERT INTO SURVEY SELECT * FROM [SURVEY$A1:I360] IN '" _
   & wbPath & "' 'Excel 8.0;HDR=No;'"
 
   'Connect to database and insert a new table
   Set cnt = New ADODB.Connection
   With cnt
       .Open dbConnectStr
       .Execute stSQL
 
   End With
   Set cnt = Nothing
 
<o:p></o:p>
   sPath = "C:\Documents and Settings\CATM2567\Desktop\Done\" & Range("C2") & ".xls"
   ActiveWorkbook.SaveAs sPath
<o:p></o:p>
End Sub


Thank you once again for all your help.
 
Upvote 0
Thanks for sharing your success. It is a very well written procedure I think -- a good example of using ADOX with VBA.
 
Upvote 0
elcorazon

Are you creating hundreds of databases with only a single table in each?:eek:
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,251
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top