Help with macro to extract different data to 2 sheets.

Kayslover

Board Regular
Joined
Sep 22, 2020
Messages
138
Office Version
  1. 2013
Platform
  1. Windows
Hi all,

The following macro currently consolidates data from 4 or 5 sheets (Column A to Column N) into a single sheet called Month Expenses.
VBA Code:
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
        
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.

    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
    
    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, 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("Month Expenses")
                            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("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

Is it possible to have to 2 arrays set up which creates 2 sheets?

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

Sheet Month Expenses Non Cash to only extract data from 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.
 

Some videos you may like

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.

Kayslover

Board Regular
Joined
Sep 22, 2020
Messages
138
Office Version
  1. 2013
Platform
  1. Windows
Hi all,

I had got no replies to this thread and thought how I can get a solution.

Rather than creating 2 arrays to produce the required information I knew that the consolidation was producing all the required information and therefore I did the following:-

  • Duplicated the consolidated data (Month Expenses) and called it the (Month Non Cash Expenses);
  • On sheet called Month Expenses, I set up an Filter, and then selected NON BLANKS on column D, and then deleted all visible rows;
  • On sheet called Month Non Cash Expenses, I set up an Filter, and then selected BLANKS on column D, and then deleted all visible rows;
  • This achieved what I wanted.
I got the inspiration for the above when I came across the following link VBA Macro to Delete Rows Based on Cell Values or Conditions in Excel

I hope that the above helps people who may not realise that Filters can be used to delete unrequired data.
 
Solution

Watch MrExcel Video

Forum statistics

Threads
1,127,802
Messages
5,626,984
Members
416,213
Latest member
neflerine

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