How do I Consolidate an EXCEL Report into a record for ACCESS impo

[Mike M]

How can I set create a VBA program that can arrange a multi-row EXCEL 2007
report by consolidating the lines into one record to import it into ACCESS
2007?

Example: How can I convert all of the information below into one record?

Location Title
DATE
Prev Current Used Cost Sold Purchased
Liquor 14407.60 14767.66 819.71 $535.32 731.00 $731.30
Wine 21399.49 21989.17 931.93 $404.89 1211.06$441.72
Beer 1417 1268 341 $297.78 333 $163.60

 

[Joel]

Here are two macros. One to creatte a databae and one to submit data to the
created database. The macros use ADO methods so you have to set two
references i VBA using the VBA menu Tools - Options - Refferences

1) Microsoft Access 11.0 object library (or latest version on your PC)
2) Active ActiveX Data object 2.8 library (or latestest on your PC)


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


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