Importing Data from Access to An Excel Sheet

[Memphis]

Hello Everyone,
I am currently importing data into an excel sheet from an Access query.
I go to Data/ Import External Data/ Import data, and on the Select Data
Source I find the Shared Drive (S:\) and then find the folder where the .mdb
is found.
Now every month the path is the same, only the name of the .mdb file changes
its, basically I get a new batch of information for the new month.
What I want to look into is the possibility of creating a Macros that promps
the user for the file name they need to import the data from and have the
system do the importing for them and drop the imported data beginning with
Cell A1.
The Command button for this operation is not in the actual sheet were the
imported data is going, it is in a sheet I call “Case Controlâ€, the data
needs to be propagated to the “ImpData†sheet.

Thank you.

 

[Joel]

Turn on Macro recorder while performing the operation. Then post the code
and I will make the changes to select a file name.

 

[Memphis]

Thanks Joel, here it is:
Sub ImportDataFromAccess()
'
' ImportDataFromAccess Macro
' Macro recorded 03/13/2009 by Memphis
'

'
Sheets("PropData").Select
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User
ID=Admin;Data Source=P:\Toolbar\Redet\0109CASES.mdb;Mode=Share Deny
Write;Exte" _
, _
"nded Properties="""";Jet OLEDB:System database="""";Jet
OLEDB:Registry Path="""";Jet OLEDBatabase Password="""";Jet OLEDB:Engine
Type=" _
, _
"5;Jet OLEDBatabase Locking Mode=0;Jet OLEDB:Global Partial Bulk
Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Datab" _
, _
"ase Password="""";Jet OLEDB:Create System Database=False;Jet
OLEDB:Encrypt Database=False;Jet OLEDBon't Copy Locale on Compact=F" _
, "alse;Jet OLEDB:Compact Without Replica Repair=False;Jet
OLEDB:SFP=False"), _
Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("8508Prepqry")
.Name = "0109CASES_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "P:\Toolbar\Redet\0109CASES.mdb"
.Refresh BackgroundQuery:=False
End With
ActiveWindow.ScrollWorkbookTabs Sheets:=-1
Sheets("Control").Select
End Sub

___________________________________________________________________

 

[Joel]

I created two versions of the macro. the 1st the same as you had. Then 2nd
I removed some optional parmaeters that the macro recorder added. Not sure
if the 2nd method is going to worl because I may of taken out too many
options. Try both.


Sub ImportDataFromAccess()
'
' ImportDataFromAccess Macro
' Macro recorded 03/13/2009 by Memphis
'
DefaultFolder = "C:\temp"
ChDrive ("C:")
ChDir (DefaultFolder)

fileToOpen = Application.GetOpenFilename( _
FileFilter:="Access Files (*.mdb), *.mdb", _
Title:="OPen Database")
If fileToOpen = False Then
MsgBox ("Cannot Open file - Exiting Macro")
Exit Sub
End If

'

With Sheets("PropData").QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Password="""";" & _
"UserID=Admin;" & _
"Data Source=" & fileToOpen & ";" & _
"Mode=Share DenyWrite;" & _
"Extended Properties="""";" & _
"Jet OLEDB:System database="""";" & _
"Jet OLEDB:Registry Path="""";" & _
"Jet OLEDBatabase Password="""";" & _
"Jet OLEDB:EngineType=5;" & _
"Jet OLEDBatabase Locking Mode=0;" & _
"Jet OLEDB:Global Partial BulkOps=2;" & _
"Jet OLEDB:Global Bulk Transactions=1;" & _
"Jet OLEDB:New Database Password="""";" & _
"Jet OLEDB:Create System Database=False;" & _
"Jet OLEDB:Encrypt Database=False;" & _
"Jet OLEDBon't Copy Locale on Compact=False;" & _
"Jet OLEDB:Compact Without Replica Repair=False;" & _
"Jet OLEDB:SFP=False"), _
Destination:=Range("A1"))

.CommandType = xlCmdTable
.CommandText = Array("8508Prepqry")
.Name = "0109CASES_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = fileToOpen
.Refresh BackgroundQuery:=False
End With
Sheets("Control").Select
End Sub

Sub ImportDataFromAccess2()
'
' ImportDataFromAccess Macro
' Macro recorded 03/13/2009 by Memphis
'
DefaultFolder = "C:\temp"
ChDrive ("C:")
ChDir (DefaultFolder)

fileToOpen = Application.GetOpenFilename( _
FileFilter:="Access Files (*.mdb), *.mdb", _
Title:="OPen Database")
If fileToOpen = False Then
MsgBox ("Cannot Open file - Exiting Macro")
Exit Sub
End If

'

With Sheets("PropData").QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Password="""";" & _
"UserID=Admin;" & _
"Data Source=" & fileToOpen & ";"), _
Destination:=Range("A1"))

.CommandType = xlCmdTable
.CommandText = Array("8508Prepqry")
.Name = "0109CASES_1"
.FieldNames = True
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = fileToOpen
.Refresh BackgroundQuery:=False
End With
Sheets("Control").Select
End Sub

 

[Memphis]

Thnks Joel for your help.. The first one worked like a charm.

Memphis

 

[joel]

I'm curious why the 2nd didn't work. if you have time delete lines from the
1st macro one at a time and see which ones you can remove and still get the
macro to run. In know the ones with Null parameters can be removed. I'm
pretty sure this will work. I believe it is easier to maintain a macro when
it doesn't contain unnecessarry parameters.

Sub ImportDataFromAccess()
'
' ImportDataFromAccess Macro
' Macro recorded 03/13/2009 by Memphis
'
DefaultFolder = "C:\temp"
ChDrive ("C:")
ChDir (DefaultFolder)

fileToOpen = Application.GetOpenFilename( _
FileFilter:="Access Files (*.mdb), *.mdb", _
Title:="OPen Database")
If fileToOpen = False Then
MsgBox ("Cannot Open file - Exiting Macro")
Exit Sub
End If

'

With Sheets("PropData").QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;" & _
"UserID=Admin;" & _
"Data Source=" & fileToOpen & ";" & _
"Mode=Share DenyWrite;" & _
"Jet OLEDB:EngineType=5;" & _
"Jet OLEDBatabase Locking Mode=0;" & _
"Jet OLEDB:Global Partial BulkOps=2;" & _
"Jet OLEDB:Global Bulk Transactions=1;" & _
"Jet OLEDB:Create System Database=False;" & _
"Jet OLEDB:Encrypt Database=False;" & _
"Jet OLEDBon't Copy Locale on Compact=False;" & _
"Jet OLEDB:Compact Without Replica Repair=False;" & _
"Jet OLEDB:SFP=False"), _
Destination:=Range("A1"))

.CommandType = xlCmdTable
.CommandText = Array("8508Prepqry")
.Name = "0109CASES_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = fileToOpen
.Refresh BackgroundQuery:=False
End With
Sheets("Control").Select
End Sub