Rowan,

Sorry one more question,

I have added another excel workbook to one of the folders i am looping
through and suddenly when trying to extract cell values from that file, VBA
returns a runtime error'-2147467259 (800004005) could not decrypt file
error.

Any idea what is causing this?

Thanks again

FD

"FrigidDigit" wrote in message
...
Don't worry Rowan, Figured it out.
Thanks again to you and Ron!

"FrigidDigit" wrote in message
...
Rowan,

I have really butcheded the code provided by Ron and yourself in an
attempt to allow for the fact that the same sheet may have different
names in different workbooks. In the process I have created a bug that
causes the value of cell B4 not to be written to column a for some files.
Any chance you could point out my mistake?

Thanks!

Option Explicit
Dim SheetName As String
Private Sub btnUpdateList_Click()
'---------------------------------------------------------------------------------------
' Procedure : InvoiceListingADO
' DateTime : 17-Oct-05 16:30
' Author : Lawrence Kritzinger
' Purpose : This procedure extracts values from non-contigious cells in
all the
' workbooks in a specified directory using ADO. Thus,
workbooks do not
' need to be opened which saves a huge amount of time with
the large
' invoice workbooks.
' Notes : Based on code by R. de Bruin and R. Drummond
'---------------------------------------------------------------------------------------
Dim fname As String
Dim eRow As Long
Dim i As Integer
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim fldrs As Variant
Dim Layout As String
fldrs = Array("C:\Documents and Settings\sanis\My Documents\Test",
"C:\Documents and Settings\sanis\My Documents\Copy of Test")
Workbooks("Automated Invoice
Listing.xls").Worksheets(1).Range(Cells(2, 1), Cells(1000, 6)).Clear
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
SheetName = "Inv Summ"
For i = 0 To UBound(fldrs)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(fldrs(i))
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then
fname = objFolder.Path & "\" & objFile.Name
If InStr(1, fname, "LO01", vbTextCompare) < 0 Then
Layout = "Old Layout"
ElseIf InStr(1, fname, "LO02", vbTextCompare) < 0 Then
Layout = "Revised Layout"
ElseIf InStr(1, fname, "LO03", vbTextCompare) < 0 Then
Layout = "New Improved Layout"
Else: MsgBox "Please check file naming conventions!"
Exit Sub
End If
Select Case Layout
Case "Old Layout"
Call GetData(fname, SheetName, "B4:B4", _
Sheets(1).Cells(eRow, 1), False)
Call GetData(fname, SheetName, "H4:H4", _
Sheets(1).Cells(eRow, 2), False)
Call GetData(fname, SheetName, "H5:H5", _
Sheets(1).Cells(eRow, 3), False)
Call GetData(fname, SheetName, "H6:H6", _
Sheets(1).Cells(eRow, 4), False)
Call GetData(fname, SheetName, "H7:H7", _
Sheets(1).Cells(eRow, 5), False)
Call GetData(fname, SheetName, "G47:G47", _
Sheets(1).Cells(eRow, 6), False)
Case "Revised Layout"
Call GetData(fname, SheetName, "A10:A10", _
Sheets(1).Cells(eRow, 1), False)
Call GetData(fname, SheetName, "I11:I11", _
Sheets(1).Cells(eRow, 2), False)
Call GetData(fname, SheetName, "I12:I12", _
Sheets(1).Cells(eRow, 3), False)
Call GetData(fname, SheetName, "I13:I13", _
Sheets(1).Cells(eRow, 4), False)
Call GetData(fname, SheetName, "I14:I14", _
Sheets(1).Cells(eRow, 5), False)
Call GetData(fname, SheetName, "G55:G55", _
Sheets(1).Cells(eRow, 6), False)
End Select
eRow = eRow + 1
End If
Next

Next i
Set objFSO = Nothing
Set objFolder = Nothing
Set objFile = Nothing
End Sub

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
sourceRange As String, TargetRange As Range, HeaderRow As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : GetData
' DateTime : 18-Oct-05 10:36
' Author : Lawrence Kritzinger
' Purpose : This procedure is called by the InvoiceListingADO procedure
and extracts
' the values of certain cells via ADO.
' Notes :
'---------------------------------------------------------------------------------------
Dim rsData As ADODB.Recordset
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long

' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" _
& SourceFile & ";" & "Extended Properties=""Excel 8.0;HDR=No"";"

szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & sourceRange$ & _
"];"

On Error GoTo SomethingWrong
Set rsData = New ADODB.Recordset
rsData.Open szSQL, szConnect, adOpenForwardOnly, adLockReadOnly, _
adCmdText

' Check to make sure we received data and copy the data
If Not rsData.EOF Then

If HeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If

' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
Exit Sub

SomethingWrong:
'MsgBox "About to change name!"
If SheetName = "Invoice Summary" Then
SheetName = "Inv Summ"
ElseIf SheetName = "Inv Summ" Then
SheetName = "Invoice Summary"
End If

End Sub

"Rowan Drummond" wrote in message
...
Well bearing in mind that Ron wrote it and I just put it in a loop, you
are very welcome.

Regards
Rowan

FrigidDigit wrote:
Just telling like it is dude! You saved my @$$ bigtime!
Have a good one.

Frig

"Rowan Drummond" wrote in message
...

Flattery works everytime <g, try:

Sub CopyIt()
Dim fname As String
Dim eRow As Long
Dim i As Integer
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim fldrs As Variant

fldrs = Array("C:\Data", "C:\Temp")

eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1

For i = 0 To UBound(fldrs)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(fldrs(i))
For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then
fname = objFolder.Path & "\" & objFile.Name
Call GetData(fname, "Sheet1", "A7:A7", _
Sheets(1).Cells(eRow, 1), False)
Call GetData(fname, "Sheet1", "D8:D8", _
Sheets(1).Cells(eRow, 2), False)
Call GetData(fname, "Sheet1", "F8:F8", _
Sheets(1).Cells(eRow, 3), False)
eRow = eRow + 1
End If
Next
Next i

Set objFSO = Nothing
Set objFolder = Nothing
Set objFile = Nothing
End Sub

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
sourceRange As String, TargetRange As Range, HeaderRow As Boolean)
Dim rsData As ADODB.Recordset
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long

' Create the connection string.
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" _
& SourceFile & ";" & "Extended Properties=""Excel 8.0;HDR=No"";"

szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & sourceRange$ & _
"];"

On Error GoTo SomethingWrong
Set rsData = New ADODB.Recordset
rsData.Open szSQL, szConnect, adOpenForwardOnly, adLockReadOnly, _
adCmdText

' Check to make sure we received data and copy the data
If Not rsData.EOF Then

If HeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If

' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
Exit Sub

SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & _
SourceFile, vbExclamation, "Error"
On Error GoTo 0
End Sub

Regards
Rowan

FrigidDigit wrote:

Rowan you are a GENIUS!! This works like a bomb!
I know I'm pushing my luck now, but is there a way to loop through
several different directories (not neccessarily parent/child)?

Thanks bud!!

Frigid Digit

"Rowan Drummond" wrote in message
. ..


You're welcome!