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!

No idea on that one I am afraid.

Some guesses: check that you can open the file normally in excel (it's
not corrupted) and that it is not password protected.

Good luck
Rowan

FrigidDigit wrote:
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

Rowan,

Your suggestion about the worksheet protection was on the money, can I
unprotect the workbook via VBA without opening it?

Thanks for all your help.

FD

"Rowan Drummond" wrote in message
...
No idea on that one I am afraid.

Some guesses: check that you can open the file normally in excel (it's not
corrupted) and that it is not password protected.

Good luck
Rowan

FrigidDigit wrote:
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

the workbook is saved in an encrypted format. unprotecting it would require
opening it and saving it as an unencrypted file.

--
Regards,
Tom Ogilvy

"FrigidDigit" wrote in message
...
Rowan,

Your suggestion about the worksheet protection was on the money, can I
unprotect the workbook via VBA without opening it?

Thanks for all your help.

FD

"Rowan Drummond" wrote in message
...
No idea on that one I am afraid.

Some guesses: check that you can open the file normally in excel (it's
not
corrupted) and that it is not password protected.

Good luck
Rowan

FrigidDigit wrote:
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

Thanks Tom,

Will have to find another solution then.
FD

"Tom Ogilvy" wrote in message
...
the workbook is saved in an encrypted format. unprotecting it would
require
opening it and saving it as an unencrypted file.

--
Regards,
Tom Ogilvy

"FrigidDigit" wrote in message
...
Rowan,

Your suggestion about the worksheet protection was on the money, can I
unprotect the workbook via VBA without opening it?

Thanks for all your help.

FD

"Rowan Drummond" wrote in message
...
No idea on that one I am afraid.

Some guesses: check that you can open the file normally in excel (it's
not
corrupted) and that it is not password protected.

Good luck
Rowan

FrigidDigit wrote:
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

Hi all,

Can anyone tell me how I can determine which type to use in the code below
for, for instance, what should objFile.Type be if I want to loop through
only pdf or zip files. Is there any way in which I can find out which type
to use for any file?


For Each objFile In objFolder.Files
If objFile.Type = "Microsoft Excel Worksheet" Then

Thanks!

FD


"FrigidDigit" wrote in message
...
Thanks Tom,

Will have to find another solution then.
FD

"Tom Ogilvy" wrote in message
...
the workbook is saved in an encrypted format. unprotecting it would
require
opening it and saving it as an unencrypted file.

--
Regards,
Tom Ogilvy

"FrigidDigit" wrote in message
...
Rowan,

Your suggestion about the worksheet protection was on the money, can I
unprotect the workbook via VBA without opening it?

Thanks for all your help.

FD

"Rowan Drummond" wrote in message
...
No idea on that one I am afraid.

Some guesses: check that you can open the file normally in excel (it's
not
corrupted) and that it is not password protected.

Good luck
Rowan

FrigidDigit wrote:
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