Hi All
I have some code which extracts data from over 75 workbooks. The code which I have (below) makes totals of all the separate workbooks and does a grand total of them all.. I was wondering how I would take away the code which creates the total summaries??
I have hightlighted were I tried putting an end sub but still kepps on coming up with an error??? Any help would be really appreciated.
Thanks in advance?
Thanks
Andrew
I have some code which extracts data from over 75 workbooks. The code which I have (below) makes totals of all the separate workbooks and does a grand total of them all.. I was wondering how I would take away the code which creates the total summaries??
I have hightlighted were I tried putting an end sub but still kepps on coming up with an error??? Any help would be really appreciated.
Thanks in advance?
Rich (BB code):
Option Explicit
Dim wsLog As Worksheet
Sub ListInfobyFile()
Dim sWeeks() As String, sList As String
Dim iWeekPtr As Integer, iPtr As Integer
Dim iWkCur As Integer, iWkLow As Integer, iWkHigh As Integer
Dim wsSumm As Worksheet, WS As Worksheet, wsPWD As Worksheet
Dim Folderpath As String, Filenm As String
Dim I As Long, R As Long, C As Long, lRowTo As Long, lRowEnd As Long
Dim lRowStart As Long, lRowCU As Long, lErrNum As Long
Dim sPassword As String
Dim V As Variant, ChWeek As Variant, vFileList As Variant
Set wsSumm = Sheets("Summary")
Set wsLog = Sheets("Activity Log")
Set wsPWD = Sheets("Passwords")
'Look in this file path to get a list of files in the folder, change this as required
Folderpath = ThisWorkbook.Path
Filenm = Dir(Folderpath & "\*.xls", vbNormal + vbReadOnly)
vFileList = GetFileList(Folderpath & "/*.xls")
If IsArray(vFileList) = False Then
MsgBox "No Excel files found in " & Folderpath & vbCrLf & _
"Macro abandoned."
Exit Sub
End If
ChWeek = Application.InputBox(prompt:="Enter Week(s) required separated by comma" & vbCrLf & _
"(e.g. 1,2,3,4)..." & vbCrLf & _
"... or 'Cancel' to exit.", _
Type:=2)
If ChWeek = False Then Exit Sub
sWeeks = Split(ChWeek, ",")
iWkLow = 999
For iWeekPtr = LBound(sWeeks) To UBound(sWeeks)
iWkCur = Val(sWeeks(iWeekPtr))
If iWkCur < 1 Or iWkCur > 52 Then
MsgBox "Invalid Week number entered"
Exit Sub
End If
If iWkCur < iWkLow Then iWkLow = iWkCur
If iWkCur > iWkHigh Then iWkHigh = iWkCur
Next iWeekPtr
With wsSumm
lRowTo = .UsedRange.Row + .UsedRange.Rows.Count - 1
If lRowTo > 2 Then .Rows("4:" & lRowTo).ClearContents
lRowTo = .Cells(Rows.Count, "B").End(xlUp).Row + 1
End With
With Application
.ScreenUpdating = False
'Ensure macros dont fire when opening w/books
.EnableEvents = False
End With
For I = LBound(vFileList) To UBound(vFileList)
Filenm = vFileList(I)
If ThisWorkbook.Name <> Filenm Then
'Paste the name
lRowTo = lRowTo + 2
wsSumm.Cells(lRowTo, "A").Value = Filenm
lRowStart = lRowTo + 1
'open File
V = "*"
On Error Resume Next
V = WorksheetFunction.Match(Filenm, wsPWD.Columns("A"), 0)
On Error GoTo 0
If IsNumeric(V) Then
sPassword = wsPWD.Cells(V, "B").Text
Else
sPassword = ""
End If
On Error Resume Next
Workbooks.Open FileName:=Folderpath & "\" & Filenm, _
ReadOnly:=True, _
Password:=sPassword
lErrNum = Err.Number
On Error GoTo 0
If lErrNum > 0 Then
LogEntry ExcelFile:=Filenm, _
Week:="******", _
Message:="CANNOT OPEN"
Else
For iWeekPtr = LBound(sWeeks) To UBound(sWeeks)
Set WS = Nothing
On Error Resume Next
Set WS = Sheets(sWeeks(iWeekPtr))
On Error GoTo 0
If Not WS Is Nothing Then
If WS.Tab.ColorIndex = xlColorIndexNone Then
lRowTo = lRowTo + 1
With wsSumm
.Cells(lRowTo, "A").Value = "Week " & sWeeks(iWeekPtr)
.Cells(lRowTo, "B").Value = "NOT UPDATED"
End With
LogEntry ExcelFile:=Filenm, _
Week:="Week " & sWeeks(iWeekPtr), _
Message:="NOT UPDATED"
Else
Application.StatusBar = "Processing " & Filenm & ": Week " & _
sWeeks(iWeekPtr)
'Check Range
'Get last row to check
lRowEnd = WS.Range("B" & Rows.Count).End(xlUp).Row
'Check for values in F:L
For R = 12 To lRowEnd
If LCase$(WS.Cells(R, "B").Text) <> "total" Then
For C = 6 To 12 'Cols F:L
If Application.CountA(WS.Range(WS.Cells(R, 6), WS.Cells(R, 12))) Then 'Copy row to Summary
lRowTo = lRowTo + 1
With wsSumm
.Rows(lRowTo).Value = WS.Rows(R).Value
.Cells(lRowTo, "A").Value = "Week " & sWeeks(iWeekPtr)
End With
Exit For
End If
Next C
End If
Next R
LogEntry ExcelFile:=Filenm, _
Week:="Week " & sWeeks(iWeekPtr), _
Message:="PROCESSED"
End If
Else
lRowTo = lRowTo + 1
With wsSumm
.Cells(lRowTo, "A").Value = "Week " & sWeeks(iWeekPtr)
.Cells(lRowTo, "B").Value = "NOT FOUND"
End With
LogEntry ExcelFile:=Filenm, _
Week:="Week " & sWeeks(iWeekPtr), _
Message:="NOT FOUND"
End If
Next iWeekPtr
lRowTo = lRowTo + 2
wsSumm.Cells(lRowTo, "B").Value = "TOTAL"
For iPtr = 1 To 7
wsSumm.Cells(lRowTo, iPtr + 5).FormulaR1C1 = "=sum(R" & lRowStart & "C:R[-1]C)"
Next iPtr
wsSumm.Cells(lRowTo, "M").FormulaR1C1 = "=sum(R" & lRowStart & "C:R[-1]C)"
With Application
.DisplayAlerts = False
ActiveWorkbook.Close
.DisplayAlerts = True
End With
End If
End If
Next I
lRowTo = lRowTo + 2
wsSumm.Cells(lRowTo, "B").Value = "GRAND TOTAL"
For iPtr = 1 To 7
wsSumm.Cells(lRowTo, iPtr + 5).FormulaR1C1 = "=sum(R4C:R[-1]C)/2"
Next iPtr
wsSumm.Cells(lRowTo, "M").FormulaR1C1 = "=sum(R4C:R[-1]C)/2"With Application
.StatusBar = False
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function GetFileList(FileSpec As String) As Variant
' Courtesy John Walkenbach
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
Sub LogEntry(ByVal ExcelFile As String, _
ByVal Week As String, _
ByVal Message As String)
Dim lRow As Long
Dim vData(1 To 4) As Variant
lRow = wsLog.Cells(Rows.Count, "A").End(xlUp).Row + 1
vData(1) = Format(Now(), "dd-mmm-yy hh:mm:ss")
vData(2) = ExcelFile
vData(3) = Week
vData(4) = Message
wsLog.Range("A" & lRow & ":D" & lRow).Value = vData
End Sub
Thanks
Andrew