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

Hello Mike
I have done something similiar but I put the data into an Access table
first. I took the workbooks and opened each one up. I had to use cell
locations as the templates didnt use range names. I used counters to walk
thru the spreadsheet and create an ADO record set. I wrote the data into
Access and into a specific table. I then used querys to clean up the data
and remove any problem data. This was much easier than trying to code VBA
to find these issues and deal with them. I was then able to import the data
into a master Excel workbook and into a SQL table which was a requirement.

Good Luck



"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

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