newbie
12/20/2006 12:35:00 PM
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").GetFolder("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