Here's the codes:
-------------------------------------------------
Public FreshSheet As Boolean
' Layout and format a worksheet to record expenses
'
Sub Run_This_First()
FreshSheet = True
StartTime = Timer
With Application
.Calculation = xlManual
.ScreenUpdating = False
.DisplayAlerts = False
End With
Call SetUp_Det_Sht
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
.DisplayAlerts = True
End With
EndTime = Timer
Duration = EndTime - StartTime
MsgBox ("Length of Time to Run SpreadSheet
ss.s) = :" & Format(Duration, "00.0"))
FreshSheet = False
End Sub
' Set up a Detailed Worksheet
'
'
Sub SetUp_Det_Sht()
Dim Num_Exp
If FreshSheet Then
For i = 1 To Sheets.Count - 1 'is there a Detail Sheet in workbook?
If Sheets(i).Name = "Detail" Then Sheets(i).Delete
Next i
ExpFile = "New" 'otherwise set up a new sheet and call it Detail
Sheets.Add
ActiveSheet.Name = "Detail"
ExpFilePath = "" 'set file path to indicate brand new
End If
Sheets("Detail").Select
ActiveWindow.DisplayGridlines = False
With Cells.Font
.Name = "Arial"
.Size = 10
End With
' Erase all the extra names in sheet except for key ones
Set nms = ActiveWorkbook.Names
For Each nm In nms
If nm.Name = "Tax_class" _
Or nm.Name = "Expenses" _
Then Else nm.Delete
Next nm
Range("A1").Select
ActiveCell.Formula = "Purpose of Trip:"
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Font.FontStyle = "Bold"
.Font.Size = 14
End With
Range("A4").Select
ActiveCell.Formula = "Week of:"
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 14
End With
ActiveWorkbook.Names.Add Name:="Week_of", RefersToR1C1:= _
"=Detail!R4C5"
Range("E4").Select 'The actual week of expenses
With Selection
.Font.Name = "Arial"
.Font.FontStyle = "Bold"
.Font.Size = 12
.Font.ColorIndex = 11 'dark blue
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.RowHeight = xlAutofit
.NumberFormat = "ddd, d/mmm/yy"
End With
FormatRules = "Format example: A:UK Biz trip (non-empl;CHID
" & _
Chr(10) & " [Company Code] [:] [Trip Description] " & _
Chr(10) & "[(empl/non-empl)] identifes if trip being reimbursed" & _
Chr(10) & " [AJH[:] / CHID[:]] identifes top level of budget category" & _
Chr(10) & "where ':' forces lowest level of budget category only"
Range("E1:J1").MergeCells = False 'unmerge the cells 1st
Range("E1").Select
Selection.Rows.AutoFit 'insure column E1 is fully displayed
RowH = Selection.RowHeight 'capture the row height for later use
On Error Resume Next 'this will avoid error when trying to delete empty comment
With Range("E1")
.ClearComments
'.Comment.Delete
On Error GoTo 0 'reset so future errors are caught
.AddComment
.Comment.Shape.Width = 150
.Comment.Shape.Height = 100
'.Comment.Shape.TextFrame.AutoSize = True
.Comment.Visible = False
.Comment.Text Text:=FormatRules
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
End With
With Range("E1:G1")
.Rows.AutoFit
.WrapText = True
.MergeCells = True 'this command screws up the row height
.Font.Name = "Arial"
.Font.FontStyle = "Regular"
.Font.Size = 10
.Font.ColorIndex = xlAutomatic
End With
Rows("1:1").RowHeight = RowH 'reset the row height to what it was.
Range("F4").Select 'The warning indicator that Sun or not...
Selection.Rows.Hidden = False
ActiveCell.Formula = _
"=IF(TEXT(RC[-1],""ddd"")=""Sun"", " & _
""""",TEXT(RC[-1],""ddd"")&""; Not a Sunday; reset date"")"
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 12
.ColorIndex = 3 'Red
End With
Range("E6").Select 'Table Header
ActiveCell.Formula = "Exchange Rate"
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 12
.ColorIndex = 5 'light blue
End With
Range("E7:J7").Select 'Exhg Rate Table Header
With Selection
.RowHeight = 70 'set large enough to include all col headers and no wrap
.WrapText = True
.Orientation = xlHorizontal
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Name = "Arial"
.Font.FontStyle = "Bold"
.Font.Size = 8 'keep small enough to fit 'Reimburse' in table box
.Font.ColorIndex = 10 'Green
End With
ActiveCell.Formula = "Country"
Application.GoTo Reference:="RC[1]"
ActiveCell.Formula = "Currency "
Application.GoTo Reference:="RC[1]"
ActiveCell.Formula = "Exchange Rate to Reimbursed Currency"
Application.GoTo Reference:="RC[1]"
ActiveCell.Formula = "Reimbursed Currency"
Application.GoTo Reference:="RC[1]"
ActiveCell.Formula = "Local to US$"
Application.GoTo Reference:="RC[1]"
ActiveCell.Formula = "US$ to Local"
Range("F7:H7").Select 'For three columns in the header
With Selection
.WrapText = True
.Orientation = xlUpward
End With
Range("F8").Formula = "Miles"
Range("H8:H14").HorizontalAlignment = xlCenter
Range("H8:H14").VerticalAlignment = xlCenter
Range("J8").Formula = "0.325" 'this is default mileage reimbur rate
Range("E9").Formula = "United States"
Range("F9").Formula = "US"
Range("H9").Formula = "x" 'set the US as the default currency
Range("I9").Formula = "1"
Range("E7:J14").Select
ActiveWorkbook.Names.Add Name:="Ex_rate", RefersToR1C1:= _
"=Detail!R8C6:R14C10"
frm_PgmSelect.Progress.Caption = "Completed Exchange Rate Table"
frm_PgmSelect.Repaint
' The logic table for the currency calculation:
'1- is cur blank
' (1t)- leave ExRate blanked
' (1f)- 2- is this the reimb cur
' (2t) set ExRate=1
' (2f) 3-is this US2Loc blank
' (3t) 4-is reimb cur Loc2US blank
' (4t) set ExRate=reimb cur US2Loc/(1/this Loc2US)
' (4f) set ExRate=this Loc2US / reimb cur Loc2US
' (3f) 5-is reimb cur Loc2US blank
' (5t) set ExRate= this US2Loc / reimb cur US2Loc
' (5f) set ExRate= (1/this US2Loc)/reimb cur Loc2US
Range("G8").Formula = _
"=IF(RC[-1]="""", """"," & _
"IF(Cell(""type"",RC[1])<>""b"",1," & _
"IF(Cell(""type"",RC[3])=""b""," & _
"IF(Cell(""type"",Index(R8C9:R14C9,Match(""x"",R8C8:R14C8)))=""b""," & _
"Index(R8C10:R14C10,Match(""x"",R8C8:R14C8)) / (1/RC[2]) ," & _
"RC[2] / Index(R8C9:R14C9,Match(""x"",R8C8:R14C8)) )" & _
"," & _
"IF(Cell(""type"",Index(R8C9:R14C9,Match(""x"",R8C8:R14C8)))=""b""," & _
"RC[3] / Index(R8C10:R14C10,Match(""x"",R8C8:R14C8)) ," & _
"(1/RC[3]) / Index(R8C9:R14C9,Match(""x"",R8C8:R14C8)) ))))"
Range("G8").Copy Destination:=Range("G9:G14") 'copy the formula down the table.
Application.Calculation = xlAutomatic 'will need to calculation on to do next part
Set ExRt = Range("Ex_Rate").Offset(1, 2) 'look at ExRate col
Do While Not IsEmpty(ExRt(0, 0))
Cell_Value = ExRt(0, 0).Value
If FreshSheet Then
ExRt(0, 0).NumberFormat = "#,##0.00000" 'for a fresh sheet always use default fmt
Else
If Cell_Value < 50 Then ExRt(0, 0).NumberFormat = "#,##0.00000"
If Cell_Value >= 50 And Cell_Value < 100 Then ExRt(0, 0).NumberFormat = "###.000"
If Cell_Value >= 100 And Cell_Value < 2000 Then ExRt(0, 0).NumberFormat = "###.00"
If Cell_Value >= 2000 Then ExRt(0, 0).NumberFormat = "#,###"
End If
Set ExRt = ExRt.Offset(1, 0) 'jump to next cell down
Loop
For i = 0 To 1 'set format for rightmost cols in ExRate table
Set ExRt = Range("Ex_Rate").Offset(1, 4 + i) 'look 1st at Loc to US$ col
For R = 1 To Range("Ex_Rate").Rows.Count
Cell_Value = ExRt(0, 0).Value
If Cell_Value < 50 Then ExRt(0, 0).NumberFormat = "#,##0.0000" 'will do on empty also
If Cell_Value >= 50 And Cell_Value < 100 Then ExRt(0, 0).NumberFormat = "###.000"
If Cell_Value >= 100 And Cell_Value < 2000 Then ExRt(0, 0).NumberFormat = "###.00"
If Cell_Value >= 2000 Then ExRt(0, 0).NumberFormat = "#,###"
Set ExRt = ExRt.Offset(1, 0)
Next R
Next i
With Selection
.Borders(xlLeft).Weight = xlHairline
.Borders(xlLeft).ColorIndex = xlAutomatic
.Borders(xlRight).Weight = xlHairline
.Borders(xlRight).ColorIndex = xlAutomatic
.Borders(xlTop).Weight = xlHairline
.Borders(xlTop).ColorIndex = xlAutomatic
.Borders(xlBottom).Weight = xlHairline
.Borders(xlBottom).ColorIndex = xlAutomatic
End With
Selection.BorderAround Weight:=xlThin, ColorIndex:=xlAutomatic
Application.Calculation = xlManual 'turn calculation off from prev part
If FreshSheet Then
Num_Exp = 50 'This variable sets number rows in the Expense table
Else 'A sheet exists, so determine the rows in Expense table
Set nms = ActiveWorkbook.Names
For R = 1 To nms.Count
If (nms(R).Name = "Expenses") Then Exp_Exists = True
Next
Call x_Modify_Rmv_Extra_Rows
Range("E15").Copy Destination:=Range("F15:I15") 'erase any reminants from old versions of sheets
' Count the number of rows in the expense matrix
Num_Exp = 0 'start count at the 17th row
Set c = Range("J18")
Do While (c.Borders(xlBottom).Weight = xlHairline _
And Num_Exp < 200) 'Safety valve: stop after exp exceeds 200
Num_Exp = Num_Exp + 1
Set c = c.Offset(1, 0)
Loop
End If
Range("A16").Select 'Expense Table Header
If FreshSheet Then 'Only reset the word if this is new sheet
ActiveCell.Formula = "Activity"
End If
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 12
.ColorIndex = 5 'Light Blue
End With
frm_PgmSelect.Progress.Caption = "Format Expense Half of Detail Worksheet"
frm_PgmSelect.Repaint
Range("A17").Formula = "Date"
Columns("A").ColumnWidth = 10
Range("A18:A" & Num_Exp + 17).NumberFormat = "d mmm yy"
Range("B17").Formula = "Day"
Columns("B").ColumnWidth = 5
Range("B18").Formula = "=IF(RC[-1]="""","""",TEXT(RC[-1],""ddd""))"
Range("B18").Copy Destination:=Range("B19:B" & Num_Exp + 17)
Range("C17").Formula = "Seq"
Range("C17").Orientation = xlUpward
Columns("C").ColumnWidth = 3
Range("C18:C" & Num_Exp + 17).NumberFormat = "#"
Range("D17").Formula = "Company:Class"
Range("D17").Orientation = 90
Columns("D").ColumnWidth = 7
Range("E17").Formula = "Payee
escription"
Range("E17").ColumnWidth = 33
Range("F17").Formula = "Currency"
Range("F17").Orientation = xlUpward
Columns("F").ColumnWidth = 5
Range("G17").Formula = "Local"
Range("G18:G" & Num_Exp + 17).NumberFormat = "#,##0.00"
' Reformat the Local currency column [Col G] to insure it will fit
If Not FreshSheet Then
If Int(1 + (Log(Application.Max _
(Range("G18:G" & Num_Exp + 17))) / Log(10#))) >= 5 Then
Columns("G").ColumnWidth = 11.5
Else: Columns("G").ColumnWidth = 10
End If
Else
Columns("G").ColumnWidth = 10
End If
Range("H17").Formula = "Paid With (in Cur)"
Range("H17").WrapText = True
Columns("H").ColumnWidth = 8.5 'expanded to accomodate added data
Range("I17").Formula = "$$s from Stmnt"
Columns("I").ColumnWidth = 8
Range("I18:I" & Num_Exp + 17).NumberFormat = "#,##0.00"
Range("J17").Formula = "=""Charged in Reimb Cur (""" & _
" & INDEX(R8C6:R14C6,MATCH(""x"",R8C8:R14C8)) & " & """)"""
Columns("J").ColumnWidth = 10
Range("I17:J17").WrapText = True 'allow wrapping in both hdr columns
Range("J18").Select
'The logic table for the table calculation:
'1- is date blank?
' (1t)- leave Chgd blank
' (1f)- 2- is $$s blank?
' (2t) 3- is Currency blank?
' (3t) Use Local [noStmt,noCur]
' (3f) Local / Lkup ExRate(Cur) [noStmt,hv Cur]
' (2f) 4- is UsingCur blank?
' (4t) 5- is Cur Blank?
' (5t) Use $$s [hvStmt,noUCur, noCur]
' (5f) Use $$s / Lkup ExRate(Cur) [hvStmt,noUCur, Cur]
' (4f) 6- is Currency same as UsingCur?[hvStmt,hvUCur]
' (6t) $$s/ Lkup ExRate(Cur) [hvStmt,hvUCur,Cur sm UCur]
' (6f) $$s/ Lkup ExRate(UCur) [hvStmt,hvUCur,Cur ntsm UCur]
ActiveCell.Formula = _
"=IF(RC[-9]="""",""""," & _
"IF(CELL(""type"",RC[-1])=""b""," & _
"IF(CELL(""type"",RC[-4])=""b""," & _
"RC[-3],INT(100*RC[-3]/VLOOKUP(RC[-4],Ex_rate,2,FALSE)+0.5)/100)," & _
"IF(ISERROR(FIND(""("",RC[-2],2))," & _
"IF(CELL(""type"",RC[-4])=""b""," & _
"RC[-1]," & _
"INT(100*RC[-1]/VLOOKUP(RC[-4],Ex_rate,2,FALSE)+0.5)/100)," & _
"IF(RC[-4]=" & _
"IF(ISERROR(FIND(""("",RC[-2],2)),""""," & _
"MID(RC[-2],1+FIND(""("",RC[-2]),FIND("")"",RC[-2])-FIND(""("",RC[-2])-1))," & _
"INT(100*RC[-1]/VLOOKUP(RC[-4],Ex_rate,2,FALSE)+0.5)/100," & _
"INT(100*RC[-1]/VLOOKUP" & _
"(MID(RC[-2],1+FIND(""("",RC[-2]),FIND("")"",RC[-2])-FIND(""("",RC[-2])-1)," & _
"Ex_rate,2,FALSE)+0.5)/100))))"
ActiveCell.Copy Destination:=Range("J19:J" & Num_Exp + 17)
Range("J18:J" & Num_Exp + 17).Select 'select last currency column to set format
Selection.NumberFormat = """$""#,##0.00;[Red]-""$""#,##0.00"
Range("A17:J17").Select
' Set Column header to bold and set the color
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 9
.ColorIndex = 14 'Blue-Green
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlLeft).Weight = xlHairline
.Borders(xlLeft).ColorIndex = xlAutomatic
.Borders(xlRight).Weight = xlHairline
.Borders(xlRight).ColorIndex = xlAutomatic
End With
Selection.BorderAround Weight:=xlThin, ColorIndex:=xlAutomatic
Range("A18:J" & Num_Exp + 17).Select ' Place borders around the data
With Selection 'set the detail table to a top orientation, and no wrap
.WrapText = False
.Orientation = xlHorizontal
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Font.FontStyle = "Regular"
.Font.Bold = False
.Font.Size = 9
End With
With Selection
.Borders(xlLeft).Weight = xlHairline
.Borders(xlLeft).ColorIndex = xlAutomatic
.Borders(xlRight).Weight = xlHairline
.Borders(xlRight).ColorIndex = xlAutomatic
.Borders(xlTop).Weight = xlHairline
.Borders(xlTop).ColorIndex = xlAutomatic
.Borders(xlBottom).Weight = xlHairline
.Borders(xlBottom).ColorIndex = xlAutomatic
End With
' Set Alignment formatting exceptions
Range("B18:C" & Num_Exp + 17).HorizontalAlignment = xlCenter
Range("E18:E" & Num_Exp + 17).WrapText = True
Range("G18:G" & Num_Exp + 17).HorizontalAlignment = xlRight
Range("I18:J" & Num_Exp + 17).HorizontalAlignment = xlRight
' Set Color and Font formatting exceptions
Range("B18:B" & Num_Exp + 17).Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.ColorIndex = 30 'Brown
End With
' Insert the sum line and a base currency at bottom of table
Range("J" & Num_Exp + 17 + 1).Formula = _
"=SUM(R[" & -Num_Exp & "]C:R[-1]C)"
Range("I" & Num_Exp + 17 + 1).Formula = _
"=INDEX(R8C6:R14C6,MATCH(""x"",R8C8:R14C8))"
ActiveWorkbook.Names.Add Name:="Expenses", RefersToR1C1:= _
"=Detail!R17C1:R" & Num_Exp + 17 & "C10"
Call SetUp_Det_Pg_4Prnt
frm_PgmSelect.Progress.Caption = "Complete Detail Worksheet"
frm_PgmSelect.Repaint
ActiveSheet.DisplayAutomaticPageBreaks = True
ActiveWindow.DisplayHeadings = True
ActiveWindow.DisplayHorizontalScrollBar = True
ActiveWindow.DisplayVerticalScrollBar = True
ActiveWindow.DisplayFormulas = False
' Set viewing Window to the width of the table
Range("A17:J17").Select
ActiveWindow.Zoom = True
Range("E1").Select 'Place box at first page; trip's purpose
Exit Sub
WarnAbtSheet:
Sheets.Delete
'BoxTitle = "Duplicate Sheets"
'BoxMsg = "Detail Worksheet already exists;" & _
Chr(10) & "Please remove it"
'BoxStyle = vbOKOnly + vbInformation
'BoxResponse = MsgBox(BoxMsg, BoxStyle, BoxTitle)
End Sub
Sub SetUp_Det_Pg_4Prnt()
With ActiveSheet.PageSetup 'reset the parameters when it gets printed
.PrintTitleRows = "$16:$17"
.PrintTitleColumns = ""
.LeftHeader = " "
.CenterHeader = "&14Details of Expenses"
.RightHeader = " "
.LeftFooter = "&8Date Printed: &D"
.CenterFooter = "Page &P"
'.RightFooter = "&8 " & ExpMgmt.ExpFile 'Must be space after FontSize (Excel bug)
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.4)
.PrintGridlines = False
.CenterHorizontally = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
With ActiveWorkbook
.Title = "Expense Sheet"
.Subject = "Expenses " & Range("E4")
.Author = "AJ Haire"
.Keywords = ""
.Comments = Range("E1")
End With
End Sub
' Remove_Excess_Rows Macro
' Eliminate extra rows in the Detail sheet
'
Sub x_Modify_Rmv_Extra_Rows()
' is there a '(' in the Activity cell? Indicates that don't delete rows
If InStrRev(Range("A16"), "(") <= 0 Then
' 1st set the Size of Name:"Expenses" accuratly
Set c = Range("A18")
Num_Exp = 0
Do While Not IsEmpty(c)
Num_Exp = Num_Exp + 1
Set c = c.Offset(1, 0)
Loop
ActiveWorkbook.Names.Add Name:="Expenses", RefersToR1C1:= _
"=Detail!R17C1:R" & Num_Exp + 17 & "C10"
' 2nd sort expense matrix by the date & seq
Application.GoTo Reference:="Expenses"
Selection.Sort Key1:=Range("A18"), Order1:=xlAscending, _
Key2:=Range("C18"), Order2:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
' Delete the unnecessary rows
c.Range("A1:A50").Select
Selection.EntireRow.Delete
' Store the Sum & Base currency finder functions
Range("J" & Num_Exp + 17 + 1).Select 'The sum line should be below table
ActiveCell.Formula = "=SUM(R[-" & Num_Exp & "]C:R[-1]C)"
Range("I" & Num_Exp + 17 + 1).Select 'Store the base currency
ActiveCell.Formula = "=INDEX(R8C6:R14C6,MATCH(""x"",R8C8:R14C8))"
Else
Flag = Mid(Range("A16"), InStrRev(Range("A16"), "("), _
Len(Range("A16")) - InStrRev(Range("A16"), "(") + 1)
BoxTitle = "Prevent Row Removal"
BoxMsg = "Sheet locked from deleting empty rows;" & _
Chr(10) & "Remove keyword '" & _
Flag & "' from Activity Cell, if appropriate"
BoxStyle = vbOKOnly + vbInformation
BoxResponse = MsgBox(BoxMsg, BoxStyle, BoxTitle)
End If
Range("A17").Select 'Place box at top of expense table
frm_PgmSelect.Progress.Caption = "Await instructions"
frm_PgmSelect.Repaint
End Sub
-------------------------------------------------
Pls advise. Thks.
