Help with macro to extract different data to 2 sheets.

[Kayslover]

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.

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.

 

[Kayslover]

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.