Macro to Filter data, create new sheet with data info and paste it to new sheet and divide it into different criterias

[abessa]

Hi Everyone!</SPAN>
I have been using your forum a lot lately for answers for some of the many macros I have to put in place at work to be able to automate the work load a bit.</SPAN>
I have an expenses report which is delivered to my email every week on a Wednesday. This report contains a fair amount of information which I don’t actually need but unfortunately this cannot be changed therefore I have a macro which deletes all of the columns I don’t need and organises the data for me, including wrapping the text.</SPAN>
Now, what I need help with is to build a macro which will filter the information on cell A6(Employees Name), cell F6(Transaction Type) and also on cell M6(Month of transaction) and using the information on cell A6(Employee Name) it creates a new sheet with the employees name. When this is done, the macro needs also create unique records depending on cell M6(Dates). These are months listed in a text format from Jan-14 to Jan-20. This list is on a worksheet in the same workbook called “Dates” and this information is on Column C Range(“C2:C98”). Now, for cell F6, there’s only 3 possibilities: Cash, Corporate Credit Card or Lodge Card so on my code, I have just divided these into 3 different parts of code but then the code brings across the header of the filter, even if there is no data apart from the header.</SPAN>
This is the code I have been able to develop and find so far:

Sub Expenses_Macro()
'__________________________________________________________
'This part of the macro deletes out the columns that are not needed in the report

    Columns(3).EntireColumn.Delete
    Columns(7).EntireColumn.Delete
    Columns(7).EntireColumn.Delete
    Columns(7).EntireColumn.Delete
    Columns(8).EntireColumn.Delete
    Columns(8).EntireColumn.Delete
    Columns(12).EntireColumn.Delete
    Columns(12).EntireColumn.Delete
    Columns(12).EntireColumn.Delete
    Columns(12).EntireColumn.Delete
    Columns(12).EntireColumn.Delete
    Columns(12).EntireColumn.Delete
'________________________________________________________________________________________________
'This part of the macro formats the text and wraps the text also
   
    Range("A6:L6").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("B6").Select
    Columns("B:B").ColumnWidth = 12.86
    Columns("C:C").ColumnWidth = 12.86
    Columns("D:D").ColumnWidth = 10.57
    Columns("E:E").ColumnWidth = 11.86
    Columns("F:F").Select
    Range("F3").Activate
    Selection.ColumnWidth = 14.43
    Columns("G:G").ColumnWidth = 8.86
    Columns("H:H").ColumnWidth = 10.57
    Columns("I:I").ColumnWidth = 9.43
    Columns("J:J").ColumnWidth = 10
    Columns("K:K").ColumnWidth = 8.57
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    Columns("L:L").ColumnWidth = 55.43
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    Columns("A:L").Select
    Range("A3").Activate
    With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Rows("7:7").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    With Selection
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Rows("7:500").EntireRow.AutoFit
'________________________________________________________
' This part of the code applies a formula on column M so that it can determine the month of that the transaction took place
 
    Columns(13).EntireColumn.Delete
    Range("M6").Select
    ActiveCell.FormulaR1C1 = "Dates"
    Range("L6").Select
    Selection.Copy
    Range("M6").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("M7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-8]="""","""",LOOKUP(RC[-8],Dates!C1:C2,Dates!C3))"
    Range("M7").Select
    Selection.Copy
    Range("N7").Select
    Selection.End(xlDown).Select
    Range("L1048576").Select
    Selection.End(xlUp).Select
    Range("M97").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("N12").Select
    
    ActiveWorkbook.Save
    
'______________________________________________________________________________________________
'This part of the macro is here to create new sheets using the employees
'name and to filter the info into cash, corporate credit card and lodge card
'
'Now I need to work a way of also filtering on column M, so that
'I can also filter for the dates on the worksheet "Lists"
'This will have to separate the information in the new worksheet
 
    
    Dim ws     As Worksheet
    Dim wsNew  As Worksheet
    Dim rData  As Range
    Dim rCl    As Range
    Dim sNm    As String
    Set ws = Sheet1
        
     'extract a list of unique names
     'first clear existing list
    With ws
        Set rData = .Range(.Cells(6, 1), .Cells(.Rows.Count, 13).End(xlUp))
        .Columns(.Columns.Count).Clear
        .Range(.Cells(7, 1), .Cells(8, 1).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
         
        For Each rCl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
            sNm = rCl.Text
             'add new sheet (only if required-NB uses UDF)
            If WksExists(sNm) Then
                 'so clear contents
                Sheets(sNm).Cells.Clear
            Else
                 'new sheet required
                Set wsNew = Sheets.Add
                wsNew.Move After:=Worksheets(Worksheets.Count) 'move to end
                wsNew.Name = sNm
                Sheets("Master").Range("A1:L500").Copy
                With wsNew
                    .Cells(1).PasteSpecial xlPasteColumnWidths
                    .Cells(1).PasteSpecial xlPasteFormats
                    .Cells(1).Select
                    Application.CutCopyMode = False
                End With
                              
            End If
                    
                           
             'AutoFilter & copy to relevant sheet
            
            rData.AutoFilter Field:=1, Criteria1:=sNm
            rData.AutoFilter Field:=6, Criteria1:="Cash"
            rData.Copy Destination:=Worksheets(sNm).Cells(4, 1)
     
            
             'AutoFilter & copy to relevant sheet
            
            rData.AutoFilter Field:=1, Criteria1:=sNm
            rData.AutoFilter Field:=6, Criteria1:="Corporate Credit Card"
            rData.Copy Destination:=Worksheets(sNm).Cells(Rows.Count, 1).End(xlUp).Offset(4, 0)
            
            
                    
            
             'AutoFilter & copy to relevant sheet
            rData.AutoFilter Field:=1, Criteria1:=sNm
            rData.AutoFilter Field:=6, Criteria1:="Lodge Card"
            rData.Copy Destination:=Worksheets(sNm).Cells(Rows.Count, 1).End(xlUp).Offset(4, 0)
            
            
            
            
        Next rCl
    End With
    ws.Columns(Columns.Count).ClearContents 'remove temporary list
    rData.AutoFilter 'switch off AutoFilter
    
End Sub
 
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Sub Applying_Calculations()
    Columns(13).EntireColumn.Delete
    Range("M6").Select
    ActiveCell.FormulaR1C1 = "Dates"
    Range("L6").Select
    Selection.Copy
    Range("M6").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("M7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-8]="""","""",LOOKUP(RC[-8],Dates!C1:C2,Dates!C3))"
    Range("M7").Select
    Selection.Copy
    Range("N7").Select
    Selection.End(xlDown).Select
    Range("L1048576").Select
    Selection.End(xlUp).Select
    Range("M97").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("N12").Select
    
    ActiveWorkbook.Save
    
    End Sub

</SPAN>