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

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
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
W
  • Question
UPDATING EXCEL SHEET BASED ON CELL DATA
Replies
1
Views
380
wndncg
W
B
  • Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
268
B-radK
B
S
  • Question
I have a problem in audit trail with VBA
Replies
1
Views
161
Joe4
Joe4
A
  • Solved
copy paste from one worksheet to other but in different columns
2
Replies
18
Views
772
Joe4
Joe4

Forum statistics

Threads
1,215,650
Messages
6,126,019
Members
449,280
Latest member
Miahr

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