slow code
 

Not being a fan of FSO, I'd replace it with VBA's Dir :

Dim Filename as string

filename=dir("C:\2007\Budget 2007\061212\*.xls")
Do while filename<""
set wb2=workbooks.open(filename)
'Othercode
filename=Dir()
Loop

NickHK
P.S. Do you need the "End". Exit sub would be more appropriate. Read the
help for the consequences of End

"Newbie" wrote in message
...
I have the following code, which works, but is very slow .. can anyone
please
help me speed it up ?

Sub scandirectory()
Application.DisplayAlerts = False
r = 1
wr = 1
Dim Wb1, wb2 As Workbook
Dim i As String
Set Wb1 = ActiveWorkbook
Set FSO =
CreateObject("Scripting.FileSystemObject").GetFold er("C:\2007\Budget
2007\061212")
For Each file In FSO.files
If file.Type = "Microsoft Excel Worksheet" Then
With file
Workbooks.Open (file)
Set wb2 = ActiveWorkbook
For Each ws In wb2.Worksheets
If ws.Tab.ColorIndex = 4 Then GoSub hit

Next
wb2.Close

End With
End If
Next
Set FSO = Nothing
Application.DisplayAlerts = True
End


hit:


On Error Resume Next

sname = ws.Name
For Each ce In ws.Range("c9:n95")

m = Application.VLookup(Chr(ce.Column + 64), Range("months"), 2, 0)
i = Application.VLookup(ce.Row, Range("items"), 2, 0)

'exclusions
If ce.Value = 0 Then GoTo 100
If ce.Row = 30 Or ce.Row = 31 Or ce.Row = 32 Or ce.Row = 33 Then GoTo 100
If ce.Row < 30 Then rc = "Rev" Else rc = "Costs"
'NEED TO EXCLUDE TOTAL SHEETS!!


'write data

Wb1.Sheets("data").Cells(wr, 1) = wb2.Name
Wb1.Sheets("data").Cells(wr, 2) = sname
Wb1.Sheets("data").Cells(wr, 3) = Chr(ce.Column + 64)
Wb1.Sheets("data").Cells(wr, 4) = ce.Row
Wb1.Sheets("data").Cells(wr, 5) = ce.Value
Wb1.Sheets("data").Cells(wr, 6) = ""
Wb1.Sheets("data").Cells(wr, 7) = 2007
Wb1.Sheets("data").Cells(wr, 8) = m
Wb1.Sheets("data").Cells(wr, 9) = i
Wb1.Sheets("data").Cells(wr, 10) = rc

wr = wr + 1

100
Next

Return

End Sub