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.
 

Some videos you may like

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

xenou

MrExcel MVP, Moderator
Joined
Mar 2, 2007
Messages
16,668
Office Version
2013
Platform
Windows
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:

elcorazon

New Member
Joined
Sep 28, 2008
Messages
5
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.
 

xenou

MrExcel MVP, Moderator
Joined
Mar 2, 2007
Messages
16,668
Office Version
2013
Platform
Windows
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
 

elcorazon

New Member
Joined
Sep 28, 2008
Messages
5
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.
 

xenou

MrExcel MVP, Moderator
Joined
Mar 2, 2007
Messages
16,668
Office Version
2013
Platform
Windows
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:

xenou

MrExcel MVP, Moderator
Joined
Mar 2, 2007
Messages
16,668
Office Version
2013
Platform
Windows
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?
 

elcorazon

New Member
Joined
Sep 28, 2008
Messages
5
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.
 

xenou

MrExcel MVP, Moderator
Joined
Mar 2, 2007
Messages
16,668
Office Version
2013
Platform
Windows
Thanks for sharing your success. It is a very well written procedure I think -- a good example of using ADOX with VBA.
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
75,601
Office Version
365
Platform
Windows
elcorazon

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

Watch MrExcel Video

Forum statistics

Threads
1,101,810
Messages
5,483,044
Members
407,375
Latest member
achusp

This Week's Hot Topics

  • Finding issue in If elseif else with For each Loop
    Finding issue in If elseif else with For each Loop I have tried this below code but i'm getting in Y column filled with W005. Colud you please...
  • MsgBox Error
    Hi Guys, I have the below error show up when i try and run my macro in File1 but works fine if i copy and paste the same code into file2. [ATTACH...
  • CELL FORMAT - IF CONDITION
    My Cell Format is [B]""0.00" Cr". [/B]But in the cell, it is showing 123.00 for editing. (123 is entry figure). (Data imported from other...
  • Show numbers nearly the same
    Is this possible. I have a number that can change very time eg 0.00001234 Then I have a lot of numbers 0.0000001, 0.0000002, 0.00000004...
  • Please i need your help to create formula
    I need a formula in cell B8 to do this >>if b1=1 then multiply ( cell b8) by 10% ,if b1=2 multiply by 20%,if=3 multiply by 30%. Thank you in...
  • Got error while adding column and filter
    Got error while adding column and filter In column Z has some like "Success" and "Error". I want to add column in AA if the Z cell value is...
Top