Option Explicit
Public Sub ConsolidateExpenses()
Application.ScreenUpdating = False
Application.DisplayAlerts = True
Application.StatusBar = True
Dim a()
Dim sht
Dim ws As Worksheet
Dim rf As Range
Dim i As Integer
Dim d As Long
Dim MyNoOfWeek As Integer
Dim LstRw As Long, PrnG As Range
Dim LastRow As Long
'Dim WshSrc As Worksheet
'Dim WshTrg As Worksheet
'Set WshSrc = ThisWorkbook.Worksheets("Monthly Cash Debits")
'Set WshTrg = ThisWorkbook.Worksheets("Monthly Non Cash Debits")
Application.DisplayAlerts = False
'Get the number of weeks in the month from sheet Formula, cell H2
Sheets("Formula").Select
MyNoOfWeek = Range("H2").Value
'Have to unprotect the Weekly Sheets and Formula sheets.
'The weekly sheets are being referenced here by their Excel Internal names as the sheet names change every month, were as the Internal names stay the same.
Sheet1.Unprotect Password:=""
Sheet8.Unprotect Password:=""
Sheet10.Unprotect Password:=""
Sheet11.Unprotect Password:=""
Sheets("Monthly Cash Debits").Unprotect Password:=""
Sheets("Monthly Non Cash Debits").Unprotect Password:=""
Sheets("Formula").Unprotect Password:=""
If MyNoOfWeek = 5 Then
Sheet12.Unprotect Password:=""
End If
'If the number of week in the month is 4, then set the array to 4 sheets, otherwise set it to 5 sheets.
'The array has to be build to extract the required data from either 4 or 5 weekly sheets that the month has.
If MyNoOfWeek = 4 Then
sht = Array(Sheet1, Sheet8, Sheet10, Sheet11)
Else
sht = Array(Sheet1, Sheet8, Sheet10, Sheet11, Sheet12)
End If
Sheets("Monthly Cash Debits").Select
Range("A1").Select
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("Monthly Cash Debits").UsedRange.Offset(3).ClearContents
For i = 0 To UBound(sht)
With sht(i)
Set rf = .Columns.Find("Ref")
If Not rf Is Nothing Then
Set rf = rf.Offset(1).Resize(.Columns(1).Find("B", LookAt:=xlWhole).Row - rf.Row - 1, 14) 'This statement extracts from Col A to Col N
If Not rf Is Nothing Then
On Error Resume Next
a = rf.Columns(1).SpecialCells(xlCellTypeConstants).Resize(, 14).Value 'This statement extracts from Col A to Col N
If Err.Number = 0 Then
With Sheets("Monthly Cash Debits")
With .Range("A" & .Cells(Rows.Count, "A").End(3).Row)(2)
.Resize(UBound(a), 14) = a 'This statement extracts from Col A to Col N
Erase a
End With
End With
End If
Err.Clear
End If
End If
End With
Next
'Change the value of the sum in columns E, F and G to paste Values.
With Sheets("Monthly Cash Debits")
i = .[a3].CurrentRegion.Columns(1).Rows.Count - 3
With .[e3].Resize(, 3)
.FormulaR1C1 = "=sum(r[1]c:r[" & i & "]c)"
.Value = .Value
End With
End With
Set rf = Nothing
'Set Columns Widths.
Sheets("Monthly Cash Debits").Select
Columns("A").ColumnWidth = 7
Columns("B").ColumnWidth = 10
Columns("C").ColumnWidth = 21
Columns("D:G").ColumnWidth = 16
Columns("H:J").ColumnWidth = 12
Rows("3:200").RowHeight = 30
'Copy sheet Monthly Cash Debits and rename it Monthly Non Cash Debits
ActiveSheet.Name = "Monthly Non Cash Debits"
Application.DisplayAlerts = False
' Last statement put in to suppress the dialog box that asks the user to confirm the sheet deletion
Sheets("Monthly Non Cash Debits").Delete
ActiveSheet.Name = "Monthly Cash Debits"
Sheets("Monthly Cash Debits").Copy after:=Sheets("Monthly Cash Debits")
ActiveSheet.Name = "Monthly Non Cash Debits"
'Last statement renames the new sheet which will have been called Monthly Cash Debits (2) to Monthly Non Cash Debits
'Delete unrequired rows from sheets Monthly Cash Debits and Monthly Non Cash Debits
'Monthly Cash Debits should only shows items that have a Treasurer Ref in Column D (i.e. NON Blank).
'Monthly Non Cash Debits should only shows items that DO NOT have a Treasurer Ref in Column D (i.e. Blank).
'It is acheived by setting a filter in both sheets and using "Blanks" and "Non Blanks" in Column D to selete what should be kept and what should be deleted.
'Set reference to the sheet in the workbook.
'*******************************************************************************************************************************************************************************************************************************
'* Code from below here is not working *
'*******************************************************************************************************************************************************************************************************************************
'Work the filter on sheet called Monthly Cash Debits
'The following works out what the last row that contains data in Column A
'ActiveSheet.Name = "Monthly Cash Debits"
'With ActiveSheet
'LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'End With
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
Set ws = ThisWorkbook.Worksheets("Monthly Cash Debits")
ws.Activate 'not required but allows user to view sheet if warning message appears
'Clear any existing filters
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'1. Apply Filter to look for BLANKS in Column D in the Criteria1 and uses the Last row to set the range.
'ws.Range ("D4:D1000 ").AutoFilter Field:=4, Criteria1:=""
ws.Range("D4:D" & LastRow).AutoFilter Field:=1, Criteria1:=""
'ws.Range("D4:D1000 ").AutoFilter Field:=4, Criteria1:=""
'2. Delete Rows
Application.DisplayAlerts = False
'ws.Range("D4:D1000").SpecialCells(xlCellTypeVisible).Delete
ws.Range("D4:D" & LastRow).SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
'3. Clear Filter
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Work the filter on sheet called Monthly Non Cash Debits
'LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
'The following works out what the last row that contains data in Column A
'Sheets("Monthly Non Cash Debits").Unprotect
'With ActiveSheet
'LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'End With
'Set reference to the sheet in the workbook.
Set ws = ThisWorkbook.Worksheets("Monthly Non Cash Debits")
ws.Activate 'not required but allows user to view sheet if warning message appears
'Clear any existing filters
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'1. Apply Filter to look for NON BLANKS in Column D by using the <> in the Criteria1
'ws.Range("D4:D1000").AutoFilter Field:=4, Criteria1:="<>"
ws.Range("D4:D" & LastRow).AutoFilter Field:=1, Criteria1:="<>"
'2. Delete Rows
Application.DisplayAlerts = False
ws.Range("D4:D" & LastRow).SpecialCells(xlCellTypeVisible).Delete
'ws.Range("D4:D1000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
'3. Clear Filter
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Sheets("Monthly Non Cash Debits").Select
Columns("C").ColumnWidth = 43
Range("A3").Value = "Full Monthly Non Cash Items Totals"
'The above sets the title in A3 for sheet Monthly Non Cash Debits
'Hide columns in sheets Monthly Cash Debits and Monthly Non Cash Debits so that you only see data that is relevant.
Sheets("Monthly Cash Debits").Select
Columns("F:G").Select
Selection.EntireColumn.Hidden = True
Sheets("Monthly Non Cash Debits").Select
ActiveSheet.Unprotect
Columns("D:E").Select
Selection.EntireColumn.Hidden = True
'Set Print area for sheet
LstRw = Cells(Rows.Count, "A").End(xlUp).Row
Set PrnG = Range("A1:M" & LstRw) ' or whatever column you want
ActiveSheet.PageSetup.PrintArea = PrnG.Address
'Password protect all Sheets in the workbook, But allow formatting cells (so that when you select a cell the colour changes) and to allow Inserting of rows.
For Each ws In ActiveWorkbook.Worksheets
ws.Protect Password:="", AllowFormattingCells:=True, AllowInsertingRows:=True, AllowFiltering:=True
Next ws
'Sheets named Monthly Totals, Monthly Receipt No, Monthly Cash Debits, Monthly Non Cash Debits, and Lookup should not be Protected.
'Sheets("Monthly Totals").Unprotect ""
'Sheets("Monthly Receipt No").Unprotect ""
Sheets("Lookup").Unprotect ""
Sheets("Monthly Cash Debits").Unprotect ""
Sheets("Monthly Non Cash Debits").Unprotect ""
Sheets("Monthly Cash Debits").Select
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox "Consolidatation of monthly data has completed.", Title:="Bolton Indians Sports Club - Monthly Data Consolidation"
End Sub