Help with Macro, as it is not extracting all the data.

Kayslover

Board Regular
Joined
Sep 22, 2020
Messages
159
Office Version
  1. 2013
Platform
  1. Windows
I have the following code (macro) which is used to consolidate data from 4 or 5 sheets and output the consolidated data into a sheet called “Month Expenses”.
VBA Code:
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
        
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("Month Expenses").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.
    Sheets("Formula").Select
        MyNoOfWeek = Range("H2").Value
        
    If MyNoOfWeek = 4 Then
        sht = Array(Sheet1, Sheet8, Sheet10, Sheet11)
    Else
        sht = Array(Sheet1, Sheet8, Sheet10, Sheet11, Sheet12)
    End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    sht = Array(Sheet1, Sheet8, Sheet10, Sheet11, Sheet12)
    Sheets("Month Expenses").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, 10)
                If Not rf Is Nothing Then
                    On Error Resume Next
                    a = rf.Columns(1).SpecialCells(xlCellTypeConstants).Resize(, 10).Value
                    If Err.Number = 0 Then
                        With Sheets("Month Expenses")
                            With .Range("A" & .Cells(Rows.Count, "A").End(3).Row)(2)
                                .Resize(UBound(a), 10) = a
                                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("Month Expenses")
        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 Print area for sheet
    
    LstRw = Cells(Rows.Count, "A").End(xlUp).Row
    Set PrnG = Range("A1:L" & 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
     Next ws

'Sheets named Monthly Totals, Monthly Receipt No, Month Expenses, and Lookup should not be Protected.

    'Sheets("Monthly Totals").Unprotect ""
    'Sheets("Monthly Receipt No").Unprotect ""
    Sheets("Lookup").Unprotect ""
    Sheets("Month Expenses").Unprotect ""
    Sheets("Month Expenses").Select
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "Consolidatation of monthly data has completed.", Title:="Monthly Data Consolidation"
    
End Sub

The following is a copy of data in 1 of the sheets, (I have not included other sheets as the layout is the same).

01 January.xlsm
ABCDEFGHIJKLMN
38RefDateFromTreasurer RefReceipt AmountPay SmithPay JonesCost ClassificationComments
39000103/01/21Ancillary Payment21001£56.00Maintenance - Club HousePay Electrician for doing plugs in Club House
40000204/01/21Costco£500.00BarBar Purchases
41000303/01/21Aldi21002£3.00Cleaning ItemsFor General Cleaning
42000404/01/21B&M21003£4.00Cleaning ItemsFor General Cleaning
43000505/01/21Sainsbury21004£5.00Cleaning ItemsFor General Cleaning
44000606/01/21Asda21005£6.00Cleaning ItemsFor General Cleaning
45000707/01/21Tesco21006£7.00Cleaning ItemsFor General Cleaning
46000808/01/21Morrissions21007£8.00Cleaning ItemsFor General Cleaning
47000909/01/21Lidl21008£9.00Cleaning ItemsFor General Cleaning
48001001/01/21Poundstretcher21009£10.00Cleaning ItemsFor General Cleaning
49001102/01/21Alan Hartley21010£11.00Cleaning ItemsFor General Cleaning
50001203/01/21Boss Gas21011£12.00Cleaning ItemsFor General Cleaning
51001304/01/21Amazon21012£13.00Cleaning ItemsFor General Cleaning
52001405/01/21Canal Cellars21013£14.00Cleaning ItemsFor General Cleaning
53001506/01/21Heron Foods21014£15.00Cleaning ItemsFor General Cleaning
54001607/01/21Costco21015£16.00Cleaning ItemsFor General Cleaning
55001708/01/21Booker21016£17.00Cleaning ItemsFor General Cleaning
56001809/01/21Aldi21017£18.00Cleaning ItemsFor General Cleaning
57001901/01/21B&M21018£19.00Cleaning ItemsFor General Cleaning
58002002/01/21Sainsbury21019£20.00Cleaning ItemsFor General Cleaning
59002103/01/21Asda21020£21.00Cleaning ItemsFor General Cleaning
60002204/01/21Tesco21021£22.00Cleaning ItemsFor General Cleaning
61002305/01/21Morrissions21022£23.00Cleaning ItemsFor General Cleaning
62002406/01/21Lidl21023£24.00Cleaning ItemsFor General Cleaning
63002507/01/21Poundstretcher21024£25.00Cleaning ItemsFor General Cleaning
64002608/01/21Alan Hartley21025£26.00Cleaning ItemsFor General Cleaning
65002709/01/21Boss Gas21026£27.00Cleaning ItemsFor General Cleaning
66002801/01/21Amazon21027£28.00Cleaning ItemsFor General Cleaning
67002902/01/21Canal Cellars21028£29.00Cleaning ItemsFor General Cleaning
68003003/01/21Heron Foods21029£30.00Cleaning ItemsFor General Cleaning
69003104/01/21Costco21030£31.00Cleaning ItemsFor General Cleaning
70003205/01/21Booker21031£32.00Cleaning ItemsFor General Cleaning
71003306/01/21Aldi21032£33.00Cleaning ItemsFor General Cleaning
72003407/01/21B&M21033£34.00Cleaning ItemsFor General Cleaning
73003508/01/21Sainsbury21034£35.00Cleaning ItemsFor General Cleaning
74
75
76
77BTOTAL (B)£683.00£500.00£0.00
03-Jan-21
Cell Formulas
RangeFormula
E77:G77E77=SUM(E39:E76)


The following is the output generate by running the macro.

The problem with the macro is that I have almost all the data in the Monthly Expenses sheet, EXCEPT data from columns K to N are not extracted.

You will note that data from columns K to N from sheet called 03-Jan-21 are NOT being transferred to Columns K and N in the sheet called Month Expenses. This is also the case for other sheets that are part of the Array.

Any ideas why data from columns K to N are not being populated?

I will be grateful for any assistance offered.

01 January.xlsm
ABCDEFGHIJKL
1Monthly Cash Expenses for January 2021
2RefDateFromTreasurer RefReceipt AmountPay SmithPay JonesCost ClassificationComments
3Full Monthly Cash Items Totals£1,463.00£690.00£371.00
4000103/01/21Ancillary Payment21001£56.00Maintenance - Club House
5000204/01/21Costco£500.00Bar
6000303/01/21Aldi21002£3.00Cleaning Items
7000404/01/21B&M21003£4.00Cleaning Items
8000505/01/21Sainsbury21004£5.00Cleaning Items
9000606/01/21Asda21005£6.00Cleaning Items
10000707/01/21Tesco21006£7.00Cleaning Items
11000808/01/21Morrissions21007£8.00Cleaning Items
12000909/01/21Lidl21008£9.00Cleaning Items
13001001/01/21Poundstretcher21009£10.00Cleaning Items
14001102/01/21Alan Hartley21010£11.00Cleaning Items
15001203/01/21Boss Gas21011£12.00Cleaning Items
16001304/01/21Amazon21012£13.00Cleaning Items
17001405/01/21Canal Cellars21013£14.00Cleaning Items
18001506/01/21Heron Foods21014£15.00Cleaning Items
19001607/01/21Costco21015£16.00Cleaning Items
20001708/01/21Booker21016£17.00Cleaning Items
21001809/01/21Aldi21017£18.00Cleaning Items
22001901/01/21B&M21018£19.00Cleaning Items
23002002/01/21Sainsbury21019£20.00Cleaning Items
24002103/01/21Asda21020£21.00Cleaning Items
25002204/01/21Tesco21021£22.00Cleaning Items
26002305/01/21Morrissions21022£23.00Cleaning Items
27002406/01/21Lidl21023£24.00Cleaning Items
28002507/01/21Poundstretcher21024£25.00Cleaning Items
29002608/01/21Alan Hartley21025£26.00Cleaning Items
30002709/01/21Boss Gas21026£27.00Cleaning Items
31002801/01/21Amazon21027£28.00Cleaning Items
32002902/01/21Canal Cellars21028£29.00Cleaning Items
33003003/01/21Heron Foods21029£30.00Cleaning Items
34003104/01/21Costco21030£31.00Cleaning Items
35003205/01/21Booker21031£32.00Cleaning Items
36003306/01/21Aldi21032£33.00Cleaning Items
37003407/01/21B&M21033£34.00Cleaning Items
38003508/01/21Sainsbury21034£35.00Cleaning Items
39003615/01/21Booker£200.00Bar
40003716/01/21Ancillary Payment21035£300.00Coco Services
41003821/01/21Amazon21036£53.00Maintenance - Ground
42003921/01/21Tesco21037£21.00Fuel for Machinery
43004021/01/21Amazon£10.00Bar
44004121/01/21Tesco£11.00Bar
45004221/01/21Amazon£12.00Bar
46004321/01/21Tesco£13.00Bar
47004421/01/21Amazon£14.00Bar
48004521/01/21Tesco£15.00Bar
49004621/01/21Amazon£16.00Bar
50004721/01/21Tesco£17.00Bar
51004821/01/21Amazon£18.00Bar
52004921/01/21Tesco£19.00Bar
53005021/01/21Amazon£20.00Bar
54005121/01/2021Tesco£21.00Bar
55005221/01/2021Amazon£22.00Bar
56005321/01/2021Tesco£23.00Bar
57005421/01/2021Amazon£24.00Bar
58005521/01/2021Tesco£25.00Bar
59005621/01/2021Amazon£26.00Bar
60005721/01/2021Tesco£27.00Bar
61005821/01/2021Home Bargains£28.00Bar
62005901/02/2021B&M21038£1.00Cleaning Items
Month Expenses
Cell Formulas
RangeFormula
A1A1="Monthly Cash Expenses for "&" "&TEXT(Formula!E2,"MMMM yyyy")
A3A3="Full Monthly Cash Items Totals"
Cells with Data Validation
CellAllowCriteria
C4:C22,C24:C53List=Brought_Id
C23List=Brought_Id
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,444
Office Version
  1. 365
Platform
  1. Windows
The 2nd argument in all your Range.Resize is 10 which takes you to col J (based on starting in col A), try changing it to 14
 
Solution

Kayslover

Board Regular
Joined
Sep 22, 2020
Messages
159
Office Version
  1. 2013
Platform
  1. Windows
Fluff,

That was quick. I just switched off my PC so will try out your recommendations tomorrow.

Thank you very much.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,444
Office Version
  1. 365
Platform
  1. Windows
Ok, that's fine :)
 

Kayslover

Board Regular
Joined
Sep 22, 2020
Messages
159
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Fluff,

Changed all occurrences of 10 to 14 and it works as expected, so thank you very much. :):)(y). You are a 😇.

I have a futher question for you on the macro. Is it possible to have to 2 arrays set up which creates 2 sheets?

Sheet Month Expenses to only extract Column A to E, and H to N providing there is data in Column D.

Sheet Month Expenses Non Cash to only extract Column A to C, and F to N providing there is data in Column F or G.

Any further assistance you can offer will be appreciated.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,444
Office Version
  1. 365
Platform
  1. Windows
As that is a totally different question it needs a new thread. Thanks
 

Kayslover

Board Regular
Joined
Sep 22, 2020
Messages
159
Office Version
  1. 2013
Platform
  1. Windows
Fluff,

Ok, will start a new thread and once again thanks you very much for your assistance.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,444
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Forum statistics

Threads
1,141,413
Messages
5,706,298
Members
421,440
Latest member
cmphares

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top