Does anyone know how to get the data from all subdirectories of
c:\audit\contractors\ ???
Thanks
deejayh Wrote:
Hi Ron,

Many thanks for that - but being a complete novice I cannot see how to
add the http://www.rondebruin.nl/fso.htm - FileSystemObject

I have now put the data as follows:
c:\audit
example:
c:\audit\contractors\supplier1\ddd.xls
c:\audit\contractors\supplier2\sss.xls

The range to check is B8:B400
The column is I


Code:
--------------------
Sub Example1_Filter_Workbooks()
'Note: This example use the function LastRow
Dim basebook As Workbook
Dim mybook As Workbook
Dim rng As Range
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim str As String

SaveDriveDir = CurDir
MyPath = "C:\audit\Contractors\" '<<< Change
ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
str = Sheets("Code").ComboBox2.Value
Do While FNames < ""

'Find the last row on the first sheet(used to copy the data below the data that exist)
rnum = LastRow(basebook.Worksheets(1)) + 1

'Open the workbook
Set mybook = Workbooks.Open(FNames)

With mybook.Sheets(1)
Set rng = Nothing

'Close AutoFilter first
.AutoFilterMode = False

'This example filter on column A for ron, Note: A1 is the Header cell
'Change the range and criteria to your Range/Criteria
.Range("B8:B400").AutoFilter Field:=1, Criteria1:=str '<<< Change

With .AutoFilter.Range

' Set a range without the Header cell
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

'If there isdata copy the rows
If Not rng Is Nothing Then
rng.EntireRow.Copy basebook.Worksheets(1).Cells(rnum, "A")
End If

End With

'Close AutoFilter
.AutoFilterMode = False
End With

'Close the workbook
mybook.Close False

'Go to the Next workbook in the folder
FNames = Dir()
Loop

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

--------------------

Oh the other thing, in the audits (the data to be imported) I have
some comments and pictures which are being seen when you import -
anyway to turn these off also?

Many many thanks again,
Cheers,
Dave


--
deejayh
------------------------------------------------------------------------
deejayh's Profile: http://www.excelforum.com/member.php...o&userid=34110
View this thread: http://www.excelforum.com/showthread...hreadid=540973