05-31-2004, 11:15 AM
|
|
Registered User
|
|
Join Date: 20 May 2004
Posts: 4
|
|
|
Financial Statements.xls - macro codes
Please Register to Remove these Ads
Chapter1, Page 9
Sub Update_WorksheetsList()
Dim I As Integer
On Error GoTo ErrorTrap:
'wList is the name defined to Range("A2")in 12-Worksheets List
Range(Range("wList"), Range("wList").End(xlDown)).ClearContents
For I = 1 To Sheets.Count
Range("wList").Offset(I - 1, 0).Value = Sheets(I).Name
Next I
ErrorTrap:
Exit Sub
End Sub
____________________________________________________
Chapter 1, Page 21
Sub SheetInABC_Order()
Dim I As Integer, J As Integer, ShNumber As Integer
ShNumber = Sheets.Count
On Error GoTo ErrorTrap:
For I = 1 To ShNumber - 1
For J = I + 1 To ShNumber
If Sheets(J).Name < Sheets(I).Name Then
Sheets(J).Move Before:=Sheets(I)
End If
Next
Next
Sheets(1).Select
ErrorTrap:
Exit Sub
End Sub
____________________________________________________
Chapter 8, pages 121, 125
Sub CreateMenu()
' This sub should be executed when the workbook is opened.
' NOTE: There is no error handling in this subroutine
Dim MenuSheet As Worksheet
Dim MenuObject As CommandBarPopup
Dim MenuItem As Object
Dim SubMenuItem As CommandBarButton
Dim Row As Integer
Dim MenuLevel, NextLevel, PositionOrMacro, Caption, Divider, FaceId
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Location for menu data
Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Make sure the menus aren't duplicated
Call DeleteMenu
' Initialize the row counter
Row = 2
' Add the menus, menu items and submenu items using
' data stored on MenuSheet
Do Until IsEmpty(MenuSheet.Cells(Row, 1))
With MenuSheet
MenuLevel = .Cells(Row, 1)
Caption = .Cells(Row, 2)
PositionOrMacro = .Cells(Row, 3)
Divider = .Cells(Row, 4)
FaceId = .Cells(Row, 5)
NextLevel = .Cells(Row + 1, 1)
End With
Select Case MenuLevel
Case 1 ' A Menu
' Add the top-level menu to the Worksheet CommandBar
Set MenuObject = Application.CommandBars(1). _
Controls.Add(Type:=msoControlPopup, _
Before:=PositionOrMacro, _
temporary:=True)
MenuObject.Caption = Caption
Case 2 ' A Menu Item
If NextLevel = 3 Then
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
Else
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
MenuItem.OnAction = PositionOrMacro
End If
MenuItem.Caption = Caption
If FaceId <> "" Then MenuItem.FaceId = FaceId
If Divider Then MenuItem.BeginGroup = True
Case 3 ' A SubMenu Item
Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)
SubMenuItem.Caption = Caption
SubMenuItem.OnAction = PositionOrMacro
If FaceId <> "" Then SubMenuItem.FaceId = FaceId
If Divider Then SubMenuItem.BeginGroup = True
End Select
Row = Row + 1
Loop
End Sub
Sub DeleteMenu()
' This sub should be executed when the workbook is closed
' Deletes the Menus
Dim MenuSheet As Worksheet
Dim Row As Integer
Dim Caption As String
On Error Resume Next
Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")
Row = 2
Do Until IsEmpty(MenuSheet.Cells(Row, 1))
If MenuSheet.Cells(Row, 1) = 1 Then
Caption = MenuSheet.Cells(Row, 2)
Application.CommandBars(1).Controls(Caption).Delete
End If
Row = Row + 1
Loop
On Error GoTo 0
End Sub
Sub ShowFaceIDs()
Dim NewToolbar As CommandBar
Dim NewButton As CommandBarButton
Dim I As Integer, IDStart As Integer, IDStop As Integer
' Delete existing FaceIds toolbar if it exists
On Error Resume Next
Application.CommandBars("FaceIds").Delete
On Error GoTo 0
' Add an empty toolbar
Set NewToolbar = Application.CommandBars.Add _
(Name:="FaceIds", temporary:=True)
NewToolbar.Visible = True
' Change the following values to see different FaceIDs
IDStart = 251
IDStop = 500
For I = IDStart To IDStop
Set NewButton = NewToolbar.Controls.Add _
(Type:=msoControlButton, ID:=2950)
NewButton.FaceId = I
NewButton.Caption = "FaceID = " & I
Next I
NewToolbar.Width = 600
End Sub
____________________________________________________
Chapter 10, page 185
Sub Print_Financial_Statements()
Dim NumberPages As Integer, I As Integer
Dim ViewName As String
Application.ScreenUpdating = False
NumberPages = ActiveWorkbook.CustomViews.Count
For I = 1 To NumberPages
ViewName = ActiveWorkbook.CustomViews(I).Name
ActiveWorkbook.CustomViews(ViewName).Show
With ActiveSheet.PageSetup
.CenterFooter = I
.LeftFooter = ActiveWorkbook.FullName & "&A &T &D"
End With
ActiveSheet.PrintOut
Next I
Application.ScreenUpdating = True
End Sub
____________________________________________________
Chapter 10, page 187
Sub Save_Financial_Statements()
Dim oSheet As Worksheet
Dim DateTimeStamp As String, CusViewName As String
Dim WB1 As String, WB2 As String, PH As String
Dim NumberCusViews As Integer, SheetsNum As Integer, I As Integer
Application.ScreenUpdating = False
'Create Date & Time Stamp
DateTimeStamp = Format(Now, "mmmm, dd yyyy HH-MM-SS")
WB1 = ActiveWorkbook.Name
NumberCusViews = ActiveWorkbook.CustomViews.Count
PH = ActiveWorkbook.Path
Workbooks.Add
'Save the new workbook at the same folder where the Financial Statements.xls
ActiveWorkbook.SaveAs Filename:=PH & "/" & "Financial Statements" & " " & "Saved at " & _
DateTimeStamp & ".xls"
'Check the number of sheets included in the new workbook, add if necessary
SheetsNum = ActiveWorkbook.Sheets.Count
Do While SheetsNum < NumberCusViews
Sheets.Add
SheetsNum = ActiveWorkbook.Sheets.Count
Loop
WB2 = ActiveWorkbook.Name
Windows(WB1).Activate
For I = 1 To NumberCusViews
ActiveWorkbook.CustomViews(I).Show
Selection.EntireColumn.Copy
Windows(WB2).Activate
Sheets(I).Select
ActiveSheet.Paste
Selection.Formula = Selection.Value
ActiveSheet.DrawingObjects.Delete
Rows("1:3").Delete
Application.CutCopyMode = False
Range("a1").Select
Windows(WB1).Activate
Next
Workbooks(WB2).Save
Windows(WB1).Activate
Application.ScreenUpdating = True
End Sub
|
Linear Mode
