The company Intanet and Network dirvers are probably on the same server
and the only dirfferent is the I: is just an alias to the real network
drive which has a name starting wit two slashes
(\\myserver\mname\....).
I have 3 macros below which you can run from Excel VBA just change tghe
file names where the database is located. to run from Excel VBA you
need to add two references from the VBA menu tools - References
1) MicrosoftAccess 11.0 object library (or latest version on you pc)
2) Microsoft ActiveX object 2.8 library (or latest on your PC)
Make sure you click the check box next to each library.
the macro below will create a database on the C: drive. You can change
the location to any place including a network drive "\\Myserver\mydir\".
After running this macro you can open the file and see the columns that
were created.
Public Const Folder = "C:\Temp\"
Public Const FName = "submission.mdb"
Sub MakeDataBase()
Const DB_Text As Long = 10
Const FldLen As Integer = 40
strDB = Folder & FName
If Dir(strDB) <> "" Then
MsgBox ("Database Exists - Exit Macro : " & strDB)
Exit Sub
End If
' Create new instance of Microsoft Access.
Set appAccess = CreateObject("Access.Application")
appAccess.Visible = True
' Open database in Microsoft Access window.
appAccess.NewCurrentDatabase strDB
' Get Database object variable.
Set dbs = appAccess.CurrentDb
' Create new table.
Set tdf = dbs.CreateTableDef("Submissions")
' Create Task/ID field in new table.
Set fld = tdf. _
CreateField("Task_ID", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld
' Create Client Name field in new table.
Set fld = tdf. _
CreateField("Client Name", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld
' Create Effective Date field in new table.
Set fld = tdf. _
CreateField("Effective Date", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld
' Create Imp Mgr field in new table.
Set fld = tdf. _
CreateField("Imp Mgr", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld
' Create Due Date field in new table.
Set fld = tdf. _
CreateField("Due Date", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld
' Create Actual Date field in new table.
Set fld = tdf. _
CreateField("Actual Date", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld
' Create Date Difference field in new table.
Set fld = tdf. _
CreateField("Date Difference", DB_Text, FldLen)
' Append Field and TableDef objects.
tdf.Fields.Append fld
dbs.TableDefs.Append tdf
Set appAccess = Nothing
End Sub
------------------------------------------------------------------------
The next macro [uts data into the above database. You would need to
setup a worksheet with data in the correct columns to run this macro.
This macro only writes data but you could modify to read as well.
Sub Submit()
'filename of database is with MakeDatabase macro
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
strDB = Folder & FName
If Dir(strDB) = "" Then
MsgBox ("Database Doesn't Exists, Create Database" & strDB)
MsgBox ("Exiting Macro")
Exit Sub
End If
ConnectStr = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Folder & FName & ";" & _
"Mode=Share Deny None;"
cn.Open (ConnectStr)
With rs
..Open Source:="Submissions", _
ActiveConnection:=cn, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdTable
If .EOF <> True Then
..MoveLast
End If
End With
With Sheets("Internal Project Plan")
ClientName = .Range("B4")
ImpMgr = .Range("B5")
LaunchDate = .Range("C4")
LastRow = .Range("K" & Rows.Count).End(xlUp).Row
For RowCount = 7 To LastRow
If UCase(.Range("K" & RowCount)) = "X" Then
DueDate = .Range("E" & RowCount)
ActualDate = .Range("F" & RowCount)
DateDif = .Range("M" & RowCount)
Accurate = .Range("L" & RowCount)
Task_ID = .Range("B" & RowCount)
With rs
..AddNew
!Task_ID = Task_ID
![Client Name] = ClientName
![Effective Date] = LaunchDate
![Imp Mgr] = ImpMgr
![Due Date] = DueDate
![Actual Date] = ActualDate
![Date Difference] = DateDif
..Update
End With
End If
Next RowCount
End With
Set appAccess = Nothing
End Sub
----------------------------------------------------------------------
The final macro setups a database query in excel to retrieve the data.
the first two macro could in one workbook for use by an admistator and
the last macro below could be for users who just need to read the data.
Again the filenames have to be changed.
Public Const Folder = "C:\Temp"
Public Const FName = "submission.mdb"
Sub CreateQuery()
'
' Macro4 Macro
' Macro recorded 1/19/2009 by Joel
'
strDB = Folder & "\" & FName
'
With ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
"ODBC;DSN=MS Access Database;" & _
"DBQ=" & strDB & ";" & _
"DefaultDir=" & Folder & ";" & _
"DriverId=25;" & _
"FIL=MS Access;" & _
"MaxBufferSize=2048;" & _
"PageTimeout=5"), _
Array(";")), Destination:=Range("A1"))
..CommandText = Array( _
"SELECT Submissions.Task_ID," & _
"Submissions.`Client Name`," & _
"Submissions.`Effective Date`," & _
"Submissions.`Imp Mgr`," & _
"Submissions.`Due Date`," & _
"Submissions.`Actual Date`," & _
"Submissions.`Date Difference`" & _
Chr(13) & "" & Chr(10) & _
"FROM `C:\temp\submission`.Submissions Submissions")
..Name = "Query from MS Access Database"
..FieldNames = True
..RowNumbers = False
..FillAdjacentFormulas = False
..PreserveFormatting = True
..RefreshOnFileOpen = True
..BackgroundQuery = True
..RefreshStyle = xlInsertDeleteCells
..SavePassword = True
..SaveData = True
..AdjustColumnWidth = True
..RefreshPeriod = 0
..PreserveColumnInfo = True
..Refresh BackgroundQuery:=False
End With
End Sub
