Hello Mike
This is obviously a specific answer to a problem that I had to work. You
should be able to get an idea of how to code so that you can change it to
meet your requirements and data. I have also used similiar to walk thru
named ranges and that makes things alot easier to code and to understand.
Post back any questions! Enjoy!
Here is an example:
Sub ADOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
Dim cn1 As ADODB.Connection
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim rs2 As ADODB.Recordset
Dim r As Long
Dim x As Integer
' remember this is in VBA in an Excel object
Dim basebook As Workbook
Dim mybook As Workbook
Dim myworksheet As Worksheet
Dim a As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim test As Variant
SaveDriveDir = CurDir
MyPath = "E:\Excel\test"
ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
' checking for datafiles in the dir and exit the sub if empty
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
' code doesnt do anything for alerts; set the property via the menu.
should work for
vb
Application.DisplayAlerts = False
Application.ScreenUpdating = False
' were in a vba excel object
Set basebook = ThisWorkbook
Do While FNames < ""
' open the excel object
Set mybook = Workbooks.Open(FNames)
Application.DisplayAlerts = 0
' open the spreadsheet object
Set myworksheet = mybook.Worksheets(1)
'Application.DisplayAlerts = False
'Workbooks.Open mybook, UpdateLinks:=0
'Application.DisplayAlerts = True
With myworksheet
' connect to the Access database
Set cn = New ADODB.Connection
' here is the location of the test Access database that will take the
data
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & "Data
Source=C:\test.mdb;"
' open an ADO recordset and instantiate the object
Set rs = New ADODB.Recordset
' insert the table name and connection used...locking is not important
in this case
rs.Open "dbo_Land_costs", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
x = 1
r = 18 ' the start row in the worksheet
'Do While Len(Range("A" & r).Formula) 0 And r < 43
Do While r < 43
i = 0
' repeat until first empty cell in column A
' this will walk all of the data first...no data verification or
checkinghere
' as Access query's will define and delete bad data
'Do While myworksheet.Range("D" & 17).Offset(1, i + 1).Value 0
'For i = 0 To 31
Do While myworksheet.Range("D" & 17).Offset(1, i + 1).Value 0
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("Something1") = myworksheet.Range("B3").Value
.Fields("Something2") = myworksheet.Range("D" & 17).Offset(0, i
+ 1).Value
.Fields("Item") = myworksheet.Range("A" & r).Value
' add some id's to identify common named cells differently in
Access
If r = 29 Then
.Fields("Item") = "Total costs" & " " &
myworksheet.Range("A" & r).Value
ElseIf r = 38 Then
.Fields("Item") = "Internal costs" & " " &
myworksheet.Range("A" & r).Value
Else
.Fields("Item") = myworksheet.Range("A" & r).Value
End If
.Fields("Vendor") = myworksheet.Range("B" & r).Value
.Fields("Currency") = myworksheet.Range("C" & r).Value
.Fields("Rate") = myworksheet.Range("D" & r).Value
.Fields("Something1") = myworksheet.Range("D" & r).Offset(0, i +
1).Value
.Fields("Start_date") = myworksheet.Range("B14").Value
.Fields("End_date") = myworksheet.Range("B15").Value
.Fields("AgeMax") = myworksheet.Range("E1").Value
.Fields("AgeMin") = myworksheet.Range("D1").Value
' this is to check for a default value and if ''then assign
value
' could be used for any data check or verification
If myworksheet.Range("F1").Value = "" Then
myworksheet.Range("F1").Value = "T500"
.Fields("Category") = myworksheet.Range("F1").Value
Else
.Fields("Category") = myworksheet.Range("F1").Value
End If
.Fields("Spreadsheet") = myworksheet.Range("A2").Value
' here only the parent object name same could be done for other
parent
' property
.Fields("Spreadname") = mybook.Name
.Fields("Note1") = myworksheet.Range("E3").Value
.Fields("Note2") = myworksheet.Range("E4").Value
' add more fields if necessary...
.Update ' stores the new record
i = i + 1
End With
Loop
'Next i
r = r + 1 ' next row
Loop
rs.Close ' close but leave the object until the end of the sub
Set cn1 = New ADODB.Connection
' here is the location of the test Access database that will take the
data
' could have used the same connection but wasnt sure of some flakiness
source
cn1.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & "Data
Source=C:\test.mdb;"
' here is a new record set for the second set of data.
Set rs2 = New ADODB.Recordset
' insert the table name and connection used...locking is not important
in this case
rs2.Open "Supplements", cn1, adOpenKeyset, adLockOptimistic, adCmdTable
' this will go thru the excel supplements and record that data in
Access.
' this will value x to the correct row for the start of the supplements.
y = 46
' this is testing for a word in a cell to mark a start location
' get something to search for to compare so to control the loop.
test = ("*upplement*")
' this while loop will stop when it cant find *upplement* in the cell
' could also add and/or logic here for better values
Do While myworksheet.Range("A" & y).Value Like test
With rs2
' create a new ADO record
.AddNew
' add values to each field in the recordset
.Fields("Service_ID") = myworksheet.Range("B3").Value
.Fields("Something2") = myworksheet.Range("B6").Value
.Fields("Supplements") = myworksheet.Range("A" & y).Value
.Fields("Vendor") = myworksheet.Range("C" & y).Value
.Fields("Currency") = myworksheet.Range("E" & y).Value
.Fields("Rate") = myworksheet.Range("F" & y).Value
.Fields("Local") = myworksheet.Range("G" & y).Value
.Fields("USD") = myworksheet.Range("H" & y).Value
.Fields("StartDate") = myworksheet.Range("B14").Value
.Fields("EndDate") = myworksheet.Range("B15").Value
.Fields("Something1") = myworksheet.Range("C5").Value
.Fields("Spreadsheet") = myworksheet.Range("A2").Value
.Fields("Spreadname") = mybook.Name
' stores the new record
.Update
' increment the counter for the next pass
y = y + 1
' end for the supplement section 'with'
End With
' the end of the first loop
Loop
End With
mybook.Close False
' Make sure all of the workbooks you want to process are in this
location.
' It will open all of them and then process them. The most I have
gone thru at one time is 324.
' this gets the next file name todo: if equal to zero exit
gracefully
FNames = Dir()
Loop
'Cleanup of objects
'rs.Close
rs2.Close
Set rs = Nothing
Set rs2 = Nothing
cn.Close
cn2.Close
Set cn = Nothing
Set cn2 = Nothing
' complete...there is no error checking, no error logging
' it doesnt exit gracefully...when its gone thru the list of workbooks.
' there are automation errors (generic) when the Access field is too
small
' for the Excel data. Trims could clean up the data on this side...
End Sub
"Mike Reed" wrote in message
...
Hi,
I am interested in taking data from specific cells in multiple workbooks and
compiling data into one worksheet. I have about 500 workbooks each
containing one worksheet that was created using the same template. If more
information is needed please let me know.
Thanks,
Mike