Hi Gary, here is my monstrosoty !! I have combined some of Ron de Bruins
code and the other code. What it does is opens all files in a folder and
counts the values for a month and then saves the total with the file
name as the header. With the totals per month under neath it.
Sub GetTotalsA()
Dim myPath As String, sMonth As Variant, sCont As String
Dim myFiles() As String, sPart As String, Fnum As Long, newBook As
String
Dim mybook As Workbook
Dim CalcMode As Long, col As Long, lRow As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean, blnPath As Boolean, FolderExists As Boolean
Dim arrTotals(1 To 12, 1 To 2) As Variant, i As Integer, m As
Integer
Dim arr, dt1 As Date, arrMonths As String, FolderName As String
Dim last As Long
arrMonths = ("Jan, Feb, Mar, Apr,May, June")
sMonth = InputBox("Please enter the month to process as per the
folder name...", "MONTH TO PROCESS")
myPath = "\\nv09001\za-t-m-2$\Department\T-M-20\Marieta\EngChanges\"
& sMonth
FolderExists = (Dir(myPath, vbDirectory + vbHidden) < vbNullString)
If FolderExists = False Then
MsgBox "Invalid Folder name, re-enter..."
GetFiles
End If
'-------------------------------------------------------
Workbooks.Add
'-------------------------------------------------------
'Fill in the path\folder where the files are
myPath = "\\nv09001\za-t-m-2$\Department\T-M-20\Marieta\EngChanges\"
& sMonth
ActiveWorkbook.SaveAs (myPath & "_Totals.xls")
newBook = ActiveWorkbook.Name
'Add a slash at the end if the user forget it
If Right(myPath, 1) < "\" Then
myPath = myPath & "\"
End If
'NewNumber:
' sPart = InputBox("PLease enter the part number to summarise...",
"PART NUMBER")
' If Not IsNumeric(sPart) Then
' MsgBox "Your entry is not all numeric"
' GoTo NewNumber
' End If
' If Len(sPart) < 7 Then
' MsgBox "Part Number must be 7 numbers"
' GoTo NewNumber
' End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(myPath & sPart & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath < ""
Fnum = Fnum + 1
ReDim Preserve myFiles(1 To Fnum)
myFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
lRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
'Loop through all files in the array(myFiles)
If Fnum 0 Then
For Fnum = LBound(myFiles) To UBound(myFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(myPath & myFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
'Change cell value(s) in one worksheet in mybook
On Error Resume Next
With mybook.Worksheets(1)
If .ProtectContents = False Then
col = col + 1
Range("G1:G5") = "Date"
Columns("G:G").TextToColumns
Destination:=Range("G1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Tab:=True,
FieldInfo:=Array(1, 4), _
TrailingMinusNumbers:=True
With Range("G6")
arr = .Resize(.End(xlDown).Row - .Row + 1,
2)
End With
For i = 1 To UBound(arr)
m = Month(arr(i, 1))
arrTotals(m, 2) = arrTotals(m, 2) + arr(i,
2)
Next
For i = 1 To 12
arrTotals(i, 1) = Format(DateSerial(7, i,
20), "mmm")
Next
'-----
Workbooks(newBook).Activate
'-----
' Cells(lRow, col).Resize(6, 1) = arrMonths
Cells(lRow, col) = Left(myFiles(Fnum),
Len(myFiles(Fnum)) - 4)
For i = LBound(arrTotals) To UBound(arrTotals)
Range("P" & i).Value = arrTotals(i, 2)
arrTotals(1, 2) = 0
Next
ActiveSheet.Cells(lRow + 1, col).Resize(12,
2).Value = arrTotals
Workbooks(myFiles(Fnum)).Close
savechanges:=False
col = col + 2 '<--- Must change to 1 if no
months
If col = 100 Then
lRow = ActiveSheet.Cells(Rows.Count,
"A").End(xlUp).Row + 2
col = 0
' Cells(lRow, col) = Left(myFiles(Fnum),
Len(myFiles(Fnum)) - 4)
End If
Else
ErrorYes = True
End If
End With
If Err.Number 0 Then
ErrorYes = True
Err.Clear
'Close mybook without saving
mybook.Close savechanges:=False
Else
'Save and close mybook
mybook.Close savechanges:=True
End If
On Error GoTo 0
Else
'Not possible to open the workbook
ErrorYes = True
End If
Next Fnum
End If
If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible
problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range
that not exist"
End If
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
sCont = MsgBox("Process another number ?", vbYesNo, "CONTINUE ?")
If sCont = vbYes Then
' GoTo NewNumber
End If
ColourAltLinesA
End Sub
Best regards,
Les Stout
*** Sent via Developersdex
http://www.developersdex.com ***