Need help in simplifying my macro

D

daniel95

New Member
Joined
Jul 13, 2016
Messages
14
Hi guys,

Need help in simplifying the below macro.

This macro basically filters the data and copies the filtered data into a new sheet. Then below the filtered data it creates a table which is common in all the sheets created.

I need help where after the table is created i need to copy a value from the data above.

Code: 
[COLOR=#333333]Sub MakeSheets()    Dim vList[/COLOR]    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)"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(4).FormulaR1C1 = "FabHotel Name"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "F").End(xlUp).Offset(4).FormulaR1C1 = vList(n)
            wsTemp.Cells(Rows.Count, "F").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "F").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "F").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Period"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "F").End(xlUp).Offset(1).FormulaR1C1 = "01-06-2016 to 01-07-2016"
            wsTemp.Cells(Rows.Count, "F").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "F").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "F").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Actual Room Nights"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "F").End(xlUp).Offset(1).FormulaR1C1 = " "
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "MG Room Nights"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Revenue"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Costing"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Margins"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "ARR"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Pay at hotel"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Prepaid"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "BTC"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(2).FormulaR1C1 = "Payable for the month of June"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Less : Advance Paid on June"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Amount Received on Fab EDC Machine"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Less : Pay @ Hotel"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Add- Room Night Purchase Before Agreement"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(1).FormulaR1C1 = "Payable for the month of june"
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Interior.ColorIndex = 25
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Color = vbWhite
            wsTemp.Cells(Rows.Count, "E").End(xlUp).Offset(0).Font.Bold = True
            Columns("E").ColumnWidth = 35
            Columns("F").ColumnWidth = 25
            
        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 [COLOR=#333333]End Function[/COLOR]
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Here's a bit of it (untested) :
Code: 
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
 
Upvote 0
I haven't studied the original code but if Boller's code has shortened up part of it, then this shortens the first section of that same code up further by filling the group of cell values at once. (I'm guessing that omitting offset(15) was accidental, otherwise my code would need a little more modification)

Code: 
With wsTemp.Cells(Rows.Count, "E").End(xlUp)
  With .Offset(4).Resize(17)
    .Interior.ColorIndex = 25
    .Font.Color = vbWhite
    .Font.Bold = True
    .Value = Application.Transpose(Split( _
                "FabHotel Name|Period|Actual Room Nights|MG Room Nights|Revenue|Costing|Margins|ARR|Pay at hotel|" & _
                "Prepaid|BTC|Payable for the month of June|Less : Advance Paid on June|Amount Received on Fab EDC Machine|" & _
                "Add- Room Night Purchase Before Agreement|Less : Pay @ Hotel|Payable for the month of june", "|"))
  End With
End With
 
Last edited:
Upvote 0
Thanks! It works perfectly!

Also could you help me in my query. Beside Actual Room nights i wanted to insert the value of the last value in my column H
 
Upvote 0
You must log in or register to reply here.

Similar threads

W
  • Solved
NEED TO CORRECT THIS CODE
3 4 5
Replies
49
Views
2K
Alex Blakenburg
A
M
  • Question Question
Copy File Names to Destination File
Replies
2
Views
304
metalscuba
M
B
  • Question Question
VBA Code to Send Mail to skip blank cells
Replies
1
Views
268
Micron
M
W
  • Question Question
UPDATING EXCEL SHEET BASED ON CELL DATA
Replies
1
Views
467
wndncg
W
B
  • Question Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
554
B-radK
B

Forum statistics

Threads
1,223,214
Messages
6,170,771
Members
452,353
Latest member
strainu

Share this page

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
Back
Top