VBA - Filter and formatting data into required format

Hi guys,

Need help in the below Macro code.

What it does is it filters my master data and then creates new sheet with filtered data and then below filtered data it creates a table with a little formatting.

My query is in the table below being created i wanted to insert a sum of column H beside a value. Also, i wanted to format it even more by creating borders to it. Below is my code.

Sub MakeSheets()
    Dim vList
    Dim n                     As Long
    Dim rgData                As Range
    Dim wsTemp                As Worksheet
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
        .AutoFilterMode = False
        Set rgData = .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
        vList = GetUniqueList(rgData.Offset(1).Resize(rgData.Rows.Count - 1))
        For n = LBound(vList) To UBound(vList)
            Set wsTemp = Sheets.Add
            wsTemp.Name = vList(n)
            rgData.AutoFilter field:=1, Criteria1:=vList(n)
            .UsedRange.Copy wsTemp.Cells(1)
            wsTemp.Cells(Rows.Count, "H").End(xlUp).Offset(1).FormulaR1C1 = "=SUM(R2C:R[-1]C)"
            wsTemp.Cells(Rows.Count, "AQ").End(xlUp).Offset(1).FormulaR1C1 = "=SUM(R2C:R[-1]C)"
            With wsTemp.Cells(Rows.Count, "E").End(xlUp)
    With .Offset(4).Resize(17)
        .Interior.ColorIndex = 25
        .Font.Color = vbWhite
        .Font.Bold = True
    End With
    .Offset(4) = "FabHotel Name"
    .Offset(5) = "Period"
    .Offset(6) = "Actual Room Nights"
    .Offset(7) = "MG Room Nights"
    .Offset(8) = "Revenue"
    .Offset(9) = "Costing"
    .Offset(10) = "Margins"
    .Offset(11) = "ARR"
    .Offset(12) = "Pay at hotel"
    .Offset(13) = "Prepaid"
    .Offset(14) = "BTC"
    .Offset(16) = "Payable for the month of June"
    .Offset(17) = "Less : Advance Paid on June"
    .Offset(18) = "Amount Received on Fab EDC Machine"
    .Offset(19) = "Add- Room Night Purchase Before Agreement"
    .Offset(20) = "Less : Pay @ Hotel"
    .Offset(21) = "Payable for the month of june"
End With
With wsTemp.Cells(Rows.Count, "F").End(xlUp)
    With .Offset(4).Resize(3)
        .Interior.ColorIndex = 25
        .Font.Color = vbWhite
        .Font.Bold = True
    End With
    .Offset(4) = vList(n)
    .Offset(5) = "01-06-2016 to 01-07-2016"
    .Offset(6) = " "
End With
            
        Next n
        .AutoFilterMode = False
    End With

    Application.ScreenUpdating = False

End Sub
Public Function GetUniqueList(rgData As Range) As Variant
    Dim dic                   As Object
    Dim x                     As Long
    Dim y                     As Long
    Dim data                  As Variant

    If rgData.Count = 1 Then
        GetUniqueList = Array(rgData.Value2)
    Else
        Set dic = CreateObject("Scripting.Dictionary")
        data = rgData.Value2
        For x = 1 To UBound(data, 1)
            For y = 1 To UBound(data, 2)
                dic(data(x, y)) = Empty
            Next y
        Next x
        GetUniqueList = dic.keys
    End If
End Function

Your post does not comply with Rule 1 of our Forum RULES. Your post title should accurately and concisely describe your problem, not your anticipated solution.

Use terms appropriate to a Google search. Poor thread titles, like Please Help, Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will be addressed according to the OP's experience in the forum: If you have less than 10 posts, expect (and respond to) a request to change your thread title. If you have 10 or more posts, expect your post to be locked, so you can start a new thread with an appropriate title.

To change a Title go to your first post, click EDIT then Go Advanced and change your title, if 2 days have passed ask a moderator to do it for you.

(This thread should receive no further responses until this moderation request is fulfilled, as per Forum Rule 7)

You already had a template of the table format, so why not just copy and paste it into the relevant worksheets instead of recreating it with a messy vb script

Also don't put the macro in the worksheet itself, but instead in a module

Paste the below script into a new module, and hopefully it should do what you need it to

Sub MakeSheets()
    Dim vList
    Dim n                     As Long
    Dim rgData                As Range
    Dim wsTemp                As Worksheet
    Dim LastRow               As Long
    Dim ActSht                As String
    
    Application.ScreenUpdating = False

    ActSht = ActiveSheet.Name
    Worksheets(ActSht).AutoFilterMode = False
    Set rgData = Worksheets(ActSht).Range("C1:C" & Worksheets(ActSht).Cells(Worksheets(ActSht).Rows.Count, "C").End(xlUp).Row)
    vList = GetUniqueList(rgData.Offset(1).Resize(rgData.Rows.Count - 1))
        
    For n = LBound(vList) To UBound(vList)
        Set wsTemp = Sheets.Add
        wsTemp.Name = vList(n)
        rgData.AutoFilter field:=1, Criteria1:=vList(n)
        Worksheets(ActSht).UsedRange.Copy wsTemp.Cells(1)
        wsTemp.Cells(Rows.Count, "H").End(xlUp).Offset(1).FormulaR1C1 = "=SUM(R2C:R[-1]C)"
    
        LastRow = Worksheets(wsTemp.Name).Cells(Worksheets(wsTemp.Name).Rows.Count, "A").End(xlUp).Row
        Worksheets("Table format").Range("B3:C26").Copy
        Worksheets(wsTemp.Name).Range("E" & LastRow + 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Worksheets(wsTemp.Name).Range("E" & LastRow + 4).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        Worksheets(wsTemp.Name).Range("F" & LastRow + 4).Value = wsTemp.Name
        Worksheets(wsTemp.Name).Range("F" & LastRow + 9).Value = Worksheets(wsTemp.Name).Range("H" & LastRow + 1).Value
        Cells.Cells.EntireColumn.AutoFit
    Next n
    
    Worksheets(ActSht).AutoFilterMode = False
    Application.ScreenUpdating = False

End Sub
Public Function GetUniqueList(rgData As Range) As Variant
    Dim dic                   As Object
    Dim x                     As Long
    Dim y                     As Long
    Dim data                  As Variant

    If rgData.Count = 1 Then
        GetUniqueList = Array(rgData.Value2)
    Else
        Set dic = CreateObject("Scripting.Dictionary")
        data = rgData.Value2
        For x = 1 To UBound(data, 1)
            For y = 1 To UBound(data, 2)
                dic(data(x, y)) = Empty
            Next y
        Next x
        GetUniqueList = dic.keys
    End If
End Function

btw your vba script was very messy, make sure you tab correctly