JCHC,
Something like this perhaps?
Sub tgr()
Const strFolderPath As String = "C:\Share\Corvallis Counts 7-20-2012\Edited\48 HOUR Tube Counts\"
Dim lCalc As XlCalculation
Dim lMacroSec As MsoAutomationSecurity
Dim ws As Worksheet
Dim wsDest As Worksheet
Dim arrData(1 To 65000, 1 To 3) As Variant
Dim strCurrentFile As String
Dim DataIndex As Long
strCurrentFile = Dir(strFolderPath & "*.xls*")
If Len(strCurrentFile) = 0 Then
MsgBox "No Excel files found in path:" & Chr(10) & strFolderPath & Chr(10) & Chr(10) & "Exiting Macro", , "No Files"
Exit Sub
End If
With Application
lCalc = .Calculation
lMacroSec = .AutomationSecurity
.Calculation = xlCalculationManual
.AutomationSecurity = msoAutomationSecurityForceDisable
.EnableEvents = False
.ScreenUpdating = False
End With
On Error GoTo CleanExit
Set wsDest = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
With wsDest.Range("A1:C1")
.Value = Array("A1", "A4", "Sum(C7:O54)")
.Font.Bold = True
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
DataIndex = 0
Do While Len(strCurrentFile) > 0
With Workbooks.Open(strFolderPath & strCurrentFile)
For Each ws In .Sheets
DataIndex = DataIndex + 1
arrData(DataIndex, 1) = ws.Range("A1").Text
arrData(DataIndex, 2) = ws.Range("A4").Text
arrData(DataIndex, 3) = WorksheetFunction.Sum(ws.Range("C7:O54"))
Next ws
.Close False
End With
strCurrentFile = Dir
Loop
If DataIndex > 0 Then wsDest.Range("A2:C2").Resize(DataIndex).Value = arrData
CleanExit:
With Application
.Calculation = lCalc
.AutomationSecurity = lMacroSec
.EnableEvents = True
.ScreenUpdating = True
End With
If Err.Number <> 0 Then
MsgBox Err.Description, , "Error: " & Err.Number
Err.Clear
End If
Set wsDest = Nothing
Erase arrData
End Sub
Bookmarks