Sub Shape_Index_Name()
Dim myVar As Shapes
Dim shp As Shape
Set myVar = Sheets(1).Shapes

For Each shp In myVar
MsgBox "Index = " & shp.ZOrderPosition & vbCrLf & "Name = " _
& shp.Name
Next

End Sub



' You should create a reference to the Word Object Library in the VBEditor

Sub Open_MSWord()
On Error GoTo errorHandler
Dim wdApp As Word.Application
Dim myDoc As Word.Document
Dim mywdRange As Word.Range
Set wdApp = New Word.Application

With wdApp
.Visible = True
.WindowState = wdWindowStateMaximize
End With

Set myDoc = wdApp.Documents.Add

Set mywdRange = myDoc.Words(1)

With mywdRange
.Text = Range("F6") & " This text is being used to test subroutine." & _
" More meaningful text to follow."
.Font.Name = "Comic Sans MS"
.Font.Size = 12
.Font.ColorIndex = wdGreen
.Bold = True
End With

errorHandler:

Set wdApp = Nothing
Set myDoc = Nothing
Set mywdRange = Nothing
End Sub





Sub ShowStars()
Randomize
StarWidth = 25
StarHeight = 25


For i = 1 To 10
TopPos = Rnd() * (ActiveWindow.UsableHeight - StarHeight)
LeftPos = Rnd() * (ActiveWindow.UsableWidth - StarWidth)
Set NewStar = ActiveSheet.Shapes.AddShape _
(msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight)
NewStar.Fill.ForeColor.SchemeColor = Int(Rnd() * 56)
Application.Wait Now + TimeValue("00:00:01")
DoEvents
Next i


Application.Wait Now + TimeValue("00:00:02")


Set myShapes = Worksheets(1).Shapes
For Each shp In myShapes
If Left(shp.Name, 9) = "AutoShape" Then
shp.Delete
Application.Wait Now + TimeValue("00:00:01")
End If
Next
Worksheets(1).Shapes("Message").Visible = True
End Sub



' This sub looks at every cell on the worksheet and
' if the cell DOES NOT have a formula, a date or text
' and the cell IS numeric, it unlocks the cell and
' makes the font blue. For everything else, it locks
' the cell and makes the font black. It then protects
' the worksheet.
' This has the effect of allowing someone to edit the
' numbers but they cannot change the text, dates or
' formulas.

Sub Set_Protection()
On Error GoTo errorHandler
Dim myDoc As Worksheet
Dim cel As Range
Set myDoc = ActiveSheet
myDoc.UnProtect
For Each cel In myDoc.UsedRange
If Not cel.HasFormula And _
Not TypeName(cel.Value) = "Date" And _
Application.IsNumber(cel) Then
cel.Locked = False
cel.Font.ColorIndex = 5
Else
cel.Locked = True
cel.Font.ColorIndex = xlColorIndexAutomatic
End If
Next
myDoc.Protect
Exit Sub
errorHandler:
MsgBox Error
End Sub





' Tests the value in each cell of a column and if it is greater
' than a given number, places it in another column. This is just
' an example so the source range, target range and test value may
' be adjusted to fit different requirements.

Sub Test_Values()
Dim topCel As Range, bottomCel As Range, _
sourceRange As Range, targetRange As Range
Dim x As Integer, i As Integer, numofRows As Integer
Set topCel = Range("A2")
Set bottomCel = Range("A65536").End(xlUp)
If topCel.Row > bottomCel.Row Then End ' test if source range is empty
Set sourceRange = Range(topCel, bottomCel)
Set targetRange = Range("D2")
numofRows = sourceRange.Rows.Count
x = 1
For i = 1 To numofRows
If Application.IsNumber(sourceRange(i)) Then
If sourceRange(i) > 1300000 Then
targetRange(x) = sourceRange(i)
x = x + 1
End If
End If
Next
End Sub



Sub CountNonBlankCells() 'Returns a count of non-blank cells in a selection
Dim myCount As Integer 'using the CountA ws function (all non-blanks)
myCount = Application.CountA(Selection)
MsgBox "The number of non-blank cell(s) in this selection is : "_
& myCount, vbInformation, "Count Cells"
End Sub


Sub CountNonBlankCells2() 'Returns a count of non-blank cells in a selection
Dim myCount As Integer 'using the Count ws function (only counts numbers, no text)
myCount = Application.Count(Selection)
MsgBox "The number of non-blank cell(s) containing numbers is : "_
& myCount, vbInformation, "Count Cells"
End Sub


Sub CountAllCells 'Returns a count of all cells in a selection
Dim myCount As Integer 'using the Selection and Count properties
myCount = Selection.Count
MsgBox "The total number of cell(s) in this selection is : "_
& myCount, vbInformation, "Count Cells"
End Sub


Sub CountRows() 'Returns a count of the number of rows in a selection
Dim myCount As Integer 'using the Selection & Count properties & the Rows method
myCount = Selection.Rows.Count
MsgBox "This selection contains " & myCount & " row(s)", vbInformation, "Count Rows"
End Sub


Sub CountColumns() 'Returns a count of the number of columns in a selection
Dim myCount As Integer 'using the Selection & Count properties & the Columns method
myCount = Selection.Columns.Count
MsgBox "This selection contains " & myCount & " columns", vbInformation, "Count Columns"
End Sub


Sub CountColumnsMultipleSelections() 'Counts columns in a multiple selection
AreaCount = Selection.Areas.Count
If AreaCount <= 1 Then MsgBox "The selection contains " & _ Selection.Columns.Count & " columns." Else For i = 1 To AreaCount MsgBox "Area " & i & " of the selection contains " & _ Selection.Areas(i).Columns.Count & " columns." Next i End If End Sub Sub addAmtAbs() Set myRange = Range("Range1") ' Substitute your range here mycount = Application.Count(myRange) ActiveCell.Formula = "=SUM(B1:B" & mycount & ")" ' Substitute your cell address here End Sub Sub addAmtRel() Set myRange = Range("Range1") ' Substitute your range here mycount = Application.Count(myRange) ActiveCell.Formula = "=SUM(R[" & -mycount & "]C:R[-1]C)" ' Substitute your cell address here End Sub Sub SelectDown() Range(ActiveCell, ActiveCell.End(xlDown)).Select End Sub Sub Select_from_ActiveCell_to_Last_Cell_in_Column() Dim topCel As Range Dim bottomCel As Range On Error GoTo errorHandler Set topCel = ActiveCell Set bottomCel = Cells((65536), topCel.Column).End(xlUp) If bottomCel.Row >= topCel.Row Then
Range(topCel, bottomCel).Select
End If
Exit Sub
errorHandler:
MsgBox "Error no. " & Err & " - " & Error
End Sub


Sub SelectUp()
Range(ActiveCell, ActiveCell.End(xlUp)).Select
End Sub


Sub SelectToRight()
Range(ActiveCell, ActiveCell.End(xlToRight)).Select
End Sub


Sub SelectToLeft()
Range(ActiveCell, ActiveCell.End(xlToLeft)).Select
End Sub


Sub SelectCurrentRegion()
ActiveCell.CurrentRegion.Select
End Sub


Sub SelectActiveArea()
Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select
End Sub


Sub SelectActiveColumn()
If IsEmpty(ActiveCell) Then Exit Sub
On Error Resume Next
If IsEmpty(ActiveCell.Offset(-1, 0)) Then Set TopCell = ActiveCell Else Set TopCell = ActiveCell.End(xlUp)
If IsEmpty(ActiveCell.Offset(1, 0)) Then Set BottomCell = ActiveCell Else Set BottomCell = ActiveCell.End(xlDown)
Range(TopCell, BottomCell).Select
End Sub


Sub SelectActiveRow()
If IsEmpty(ActiveCell) Then Exit Sub
On Error Resume Next
If IsEmpty(ActiveCell.Offset(0, -1)) Then Set LeftCell = ActiveCell Else Set LeftCell = ActiveCell.End(xlToLeft)
If IsEmpty(ActiveCell.Offset(0, 1)) Then Set RightCell = ActiveCell Else Set RightCell = ActiveCell.End(xlToRight)
Range(LeftCell, RightCell).Select
End Sub


Sub SelectEntireColumn()
Selection.EntireColumn.Select
End Sub


Sub SelectEntireRow()
Selection.EntireRow.Select
End Sub


Sub SelectEntireSheet()
Cells.Select
End Sub


Sub ActivateNextBlankDown()
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
End Sub


Sub ActivateNextBlankToRight()
ActiveCell.Offset(0, 1).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Select
Loop
End Sub


Sub SelectFirstToLastInRow()
Set LeftCell = Cells(ActiveCell.Row, 1)
Set RightCell = Cells(ActiveCell.Row, 256)

If IsEmpty(LeftCell) Then Set LeftCell = LeftCell.End(xlToRight)
If IsEmpty(RightCell) Then Set RightCell = RightCell.End(xlToLeft)
If LeftCell.Column = 256 And RightCell.Column = 1 Then ActiveCell.Select Else Range(LeftCell, RightCell).Select
End Sub


Sub SelectFirstToLastInColumn()
Set TopCell = Cells(1, ActiveCell.Column)
Set BottomCell = Cells(16384, ActiveCell.Column)

If IsEmpty(TopCell) Then Set TopCell = TopCell.End(xlDown)
If IsEmpty(BottomCell) Then Set BottomCell = BottomCell.End(xlUp)
If TopCell.Row = 16384 And BottomCell.Row = 1 Then ActiveCell.Select Else Range(TopCell, BottomCell).Select
End Sub


Sub SelCurRegCopy()
Selection.CurrentRegion.Select
Selection.Copy
Range("A17").Select ' Substitute your range here
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub



-----You might want to step through this using the "Watch" feature-----

Sub Accumulate()
Dim n As Integer
Dim t As Integer
For n = 1 To 10
t = t + n
Next n
MsgBox " The total is " & t
End Sub


'-----This sub checks values in a range 10 rows by 5 columns
'moving left to right, top to bottom-----

Sub CheckValues1()
Dim rwIndex As Integer
Dim colIndex As Integer
For rwIndex = 1 To 10
For colIndex = 1 To 5
If Cells(rwIndex, colIndex).Value <> 0 Then _
Cells(rwIndex, colIndex).Value = 0
Next colIndex
Next rwIndex
End Sub


'-----Same as above using the "With" statement instead of "If"-----

Sub CheckValues2()
Dim rwIndex As Integer
Dim colIndex As Integer
For rwIndex = 1 To 10
For colIndex = 1 To 5
With Cells(rwIndex, colIndex)
If Not (.Value = 0) Then Cells(rwIndex, colIndex).Value = 0
End With
Next colIndex
Next rwIndex
End Sub


'-----Same as CheckValues1 except moving top to bottom, left to right-----

Sub CheckValues3()
Dim colIndex As Integer
Dim rwIndex As Integer
For colIndex = 1 To 5
For rwIndex = 1 To 10
If Cells(rwIndex, colIndex).Value <> 0 Then _
Cells(rwIndex, colIndex).Value = 0
Next rwIndex
Next colIndex
End Sub


'-----Enters a value in 10 cells in a column and then sums the values------

Sub EnterInfo()
Dim i As Integer
Dim cel As Range
Set cel = ActiveCell
For i = 1 To 10
cel(i).Value = 100
Next i
cel(i).Value = "=SUM(R[-10]C:R[-1]C)"
End Sub


' Loop through all worksheets in workbook and reset values
' in a specific range on each sheet.

Sub Reset_Values_All_WSheets()
Dim wSht As Worksheet
Dim myRng As Range
Dim allwShts As Sheets
Dim cel As Range
Set allwShts = Worksheets

For Each wSht In allwShts
Set myRng = wSht.Range("A1:A5, B6:B10, C1:C5, D4:D10")
For Each cel In myRng
If Not cel.HasFormula And cel.Value <> 0 Then
cel.Value = 0
End If
Next cel
Next wSht

End Sub




' The distinction between Hide(False) and xlVeryHidden:
' Visible = xlVeryHidden - Sheet/Unhide is grayed out. To unhide sheet, you must set
' the Visible property to True.
' Visible = Hide(or False) - Sheet/Unhide is not grayed out

' To hide specific worksheet
Sub Hide_WS1()
Worksheets(2).Visible = Hide ' you can use Hide or False
End Sub


' To make a specific worksheet very hidden
Sub Hide_WS2()
Worksheets(2).Visible = xlVeryHidden
End Sub


' To unhide a specific worksheet
Sub UnHide_WS()
Worksheets(2).Visible = True
End Sub


' To toggle between hidden and visible
Sub Toggle_Hidden_Visible()
Worksheets(2).Visible = Not Worksheets(2).Visible
End Sub


' To set the visible property to True on ALL sheets in workbook
Sub Un_Hide_All()
Dim sh As Worksheet
For Each sh In Worksheets
sh.Visible = True
Next
End Sub


' To set the visible property to xlVeryHidden on ALL sheets in workbook.
' Note: The last "hide" will fail because you can not hide every sheet
' in a work book.
Sub xlVeryHidden_All_Sheets()
On Error Resume Next
Dim sh As Worksheet
For Each sh In Worksheets
sh.Visible = xlVeryHidden
Next
End Sub




'///....To find and select a range of dates based on the month and year only....\\\


Sub FindDates()
On Error GoTo errorHandler
Dim startDate As String
Dim stopDate As String
Dim startRow As Integer
Dim stopRow As Integer
startDate = InputBox("Enter the Start Date: (mm/dd/yy)")
If startDate = "" Then End
stopDate = InputBox("Enter the Stop Date: (mm/dd/yy)")
If stopDate = "" Then End
startDate = Format(startDate, "mm/??/yy")
stopDate = Format(stopDate, "mm/??/yy")
startRow = Worksheets("Table").Columns("A").Find(startDate, _
lookin:=xlValues, lookat:=xlWhole).Row
stopRow = Worksheets("Table").Columns("A").Find(stopDate, _
lookin:=xlValues, lookat:=xlWhole).Row
Worksheets("Table").Range("A" & startRow & ":A" & stopRow).Copy _
destination:=Worksheets("Report").Range("A1")
End
errorHandler:
MsgBox "There has been an error: " & Error() & Chr(13) _
& "Ending Sub.......Please try again", 48
End Sub



Sub MyTestArray()
Dim myCrit(1 To 4) As String ' Declaring array and setting bounds
Dim Response As String
Dim i As Integer
Dim myFlag As Boolean
myFlag = False

' To fill array with values
myCrit(1) = "A"
myCrit(2) = "B"
myCrit(3) = "C"
myCrit(4) = "D"

Do Until myFlag = True
Response = InputBox("Please enter your choice: (i.e. A,B,C or D)")
' Check if Response matches anything in array
For i = 1 To 4 'UCase ensures that Response and myCrit are the same case
If UCase(Response) = UCase(myCrit(i)) Then
myFlag = True: Exit For
End If
Next i
Loop
End Sub



'// This sub will replace information in all sheets of the workbook \\
'//...... Replace "old stuff" and "new stuff" with your info ......\\

Sub ChgInfo()
Dim Sht As Worksheet
For Each Sht In Worksheets
Sht.Cells.Replace What:="old stuff", _
Replacement:="new stuff", LookAt:=xlPart, MatchCase:=False
Next
End Sub



' This sub will move the sign from the right-hand side thus changing a text string into a value.

Sub MoveMinus()
On Error Resume Next
Dim cel As Range
Dim myVar As Range
Set myVar = Selection

For Each cel In myVar
If Right((Trim(cel)), 1) = "-" Then
cel.Value = cel.Value * 1
End If
Next

With myVar
.NumberFormat = "#,##0.00_);[Red](#,##0.00)"
.Columns.AutoFit
End With

End Sub





' This sub calls the DetermineUsedRange sub and passes
' the empty argument "usedRng".

Sub CallDetermineUsedRange()
On Error Resume Next
Dim usedRng As Range
DetermineUsedRange usedRng

MsgBox usedRng.Address

End Sub

' This sub receives the empty argument "usedRng" and determines
' the populated cells of the active worksheet, which is stored
' in the variable "theRng", and passed back to the calling sub.

Sub DetermineUsedRange(ByRef theRng As Range)
Dim FirstRow As Integer, FirstCol As Integer, _
LastRow As Integer, LastCol As Integer
On Error GoTo handleError

FirstRow = Cells.Find(What:="*", _
SearchDirection:=xlNext, _
SearchOrder:=xlByRows).Row
FirstCol = Cells.Find(What:="*", _
SearchDirection:=xlNext, _
SearchOrder:=xlByColumns).Column

LastRow = Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
LastCol = Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column

Set theRng = Range(Cells(FirstRow, FirstCol), _
Cells(LastRow, LastCol))

handleError:
End Sub





'Copies only the weekdates from a range of dates.

Sub EnterDates()
Columns(3).Clear
Dim startDate As String, stopDate As String, startCel As Integer, stopCel As Integer, dateRange As Range
On Error Resume Next

Do
startDate = InputBox("Please enter Start Date: Format(mm/dd/yy)", "START DATE")
If startDate = "" Then End
Loop Until startDate = Format(startDate, "mm/dd/yy") _
Or startDate = Format(startDate, "m/d/yy")

Do
stopDate = InputBox("Please enter Stop Date: Format(mm/dd/yy)", "STOP DATE")
If stopDate = "" Then End
Loop Until stopDate = Format(stopDate, "mm/dd/yy") _
Or stopDate = Format(stopDate, "m/d/yy")

startDate = Format(startDate, "mm/dd/yy")
stopDate = Format(stopDate, "mm/dd/yy")

startCel = Sheets(1).Columns(1).Find(startDate, LookIn:=xlValues, lookat:=xlWhole).Row
stopCel = Sheets(1).Columns(1).Find(stopDate, LookIn:=xlValues, lookat:=xlWhole).Row

On Error GoTo errorHandler

Set dateRange = Range(Cells(startCel, 1), Cells(stopCel, 1))

Call CopyWeekDates(dateRange) ' Passes the argument dateRange to the CopyWeekDates sub.

Exit Sub
errorHandler:
If startCel = 0 Then MsgBox "Start Date is not in table.", 64
If stopCel = 0 Then MsgBox "Stop Date is not in table.", 64
End Sub



Sub CopyWeekDates(myRange)
Dim myDay As Variant, cnt As Integer
cnt = 1
For Each myDay In myRange
If WeekDay(myDay, vbMonday) < numberformat = "mm/dd/yy" value =" myDay" cnt =" cnt" sourcerange =" Selection.SpecialCells(xlFormulas)" destrange =" Range(" value = "Address" value = "Formula"> 1 Then
For Each i In sourcerange
counter = counter + 1
destrange.Offset(counter, 0).Value = i.Address
destrange.Offset(counter, 1).Value = "'" & i.Formula
Next
ElseIf Selection.Count = 1 And Left(Selection.Formula, 1) = "=" Then
destrange.Offset(1, 0).Value = Selection.Address
destrange.Offset(1, 1).Value = "'" & Selection.Formula
Else
MsgBox "This cell does not contain a formula"
End If
destrange.CurrentRegion.EntireColumn.AutoFit
End Sub


Sub AddressFormulasMsgBox() 'Displays the address and formula in message box
For Each Item In Selection
If Mid(Item.Formula, 1, 1) = "=" Then
MsgBox "The formula in " & Item.Address(rowAbsolute:=False, _
columnAbsolute:=False) & " is: " & Item.Formula, vbInformation
End If
Next
End Sub



Sub DeleteRangeNames()
Dim rName As Name
For Each rName In ActiveWorkbook.Names
rName.Delete
Next rName
End Sub



Sub TypeSheet()
MsgBox "This sheet is a " & TypeName(ActiveSheet)
End Sub



Sub AddSheetWithNameCheckIfExists()
Dim ws As Worksheet
Dim newSheetName As String
newSheetName = Sheets(1).Range("A1") ' Substitute your range here
For Each ws In Worksheets
If ws.Name = newSheetName Or newSheetName = "" Or IsNumeric(newSheetName) Then
MsgBox "Sheet already exists or name is invalid", vbInformation
Exit Sub
End If
Next
Sheets.Add Type:="Worksheet"
With ActiveSheet
.Move after:=Worksheets(Worksheets.Count)
.Name = newSheetName
End With
End Sub


Sub Add_Sheet()
Dim wSht As Worksheet
Dim shtName As String
shtName = Format(Now, "mmmm_yyyy")
For Each wSht In Worksheets
If wSht.Name = shtName Then
MsgBox "Sheet already exists...Make necessary " & _
"corrections and try again."
Exit Sub
End If
Next wSht
Sheets.Add.Name = shtName
Sheets(shtName).Move After:=Sheets(Sheets.Count)
Sheets("Sheet1").Range("A1:A5").Copy _
Sheets(shtName).Range("A1")
End Sub


Sub Copy_Sheet()
Dim wSht As Worksheet
Dim shtName As String
shtName = "NewSheet"
For Each wSht In Worksheets
If wSht.Name = shtName Then
MsgBox "Sheet already exists...Make necessary " & _
"corrections and try again."
Exit Sub
End If
Next wSht
Sheets(1).Copy before:=Sheets(1)
Sheets(1).Name = shtName
Sheets(shtName).Move After:=Sheets(Sheets.Count)

End Sub



Sub ResetValuesToZero2()
For Each n In Worksheets("Sheet1").Range("WorkArea1") ' Substitute your information here
If n.Value <> 0 Then
n.Value = 0
End If
Next n
End Sub


Sub ResetTest1()
For Each n In Range("B1:G13") ' Substitute your range here
If n.Value <> 0 Then
n.Value = 0
End If
Next n
End Sub


Sub ResetTest2()
For Each n In Range("A16:G28") ' Substitute your range here
If IsNumeric(n) Then
n.Value = 0
End If
Next n
End Sub


Sub ResetTest3()
For Each amount In Range("I1:I13") ' Substitute your range here
If amount.Value <> 0 Then
amount.Value = 0
End If
Next amount
End Sub


Sub ResetTest4()
For Each n In ActiveSheet.UsedRange
If n.Value <> 0 Then
n.Value = 0
End If
Next n
End Sub


Sub ResetValues()
On Error GoTo ErrorHandler
For Each n In ActiveSheet.UsedRange
If n.Value <> 0 Then
n.Value = 0
End If
TypeMismatch:
Next n
ErrorHandler:
If Err = 13 Then 'Type Mismatch
Resume TypeMismatch
End If
End Sub


Sub ResetValues2()
For i = 1 To Worksheets.Count
On Error GoTo ErrorHandler
For Each n In Worksheets(i).UsedRange
If IsNumeric(n) Then
If n.Value <> 0 Then
n.Value = 0
ProtectedCell:
End If
End If
Next n
ErrorHandler:
If Err = 1005 Then
Resume ProtectedCell
End If
Next i
End Sub



Sub CalcPay()
On Error GoTo HandleError
Dim hours
Dim hourlyPay
Dim payPerWeek
hours = InputBox("Please enter number of hours worked", "Hours Worked")
hourlyPay = InputBox("Please enter hourly pay", "Pay Rate")
payPerWeek = CCur(hours * hourlyPay)
MsgBox "Pay is: " & Format(payPerWeek, "$##,##0.00"), , "Total Pay"
HandleError:
End Sub



'To print header, control the font and to pull second line of header (the date) from worksheet
Sub Printr()
ActiveSheet.PageSetup.CenterHeader = "&""Arial,Bold Italic""&14My Report" & Chr(13) _
& Sheets(1).Range("A1")
ActiveWindow.SelectedSheets.PrintOut Copies:=1
End Sub


Sub PrintRpt1() 'To control orientation
Sheets(1).PageSetup.Orientation = xlLandscape
Range("Report").PrintOut Copies:=1
End Sub


Sub PrintRpt2() 'To print several ranges on the same sheet - 1 copy
Range("HVIII_3A2").PrintOut
Range("BVIII_3").PrintOut
Range("BVIII_4A").PrintOut
Range("HVIII_4A2").PrintOut
Range("BVIII_5A").PrintOut
Range("BVIII_5B2").PrintOut
Range("HVIII_5A2").PrintOut
Range("HVIII_5B2").PrintOut
End Sub


'To print a defined area, center horizontally, with 2 rows as titles,
'in portrait orientation and fitted to page wide and tall - 1 copy
Sub PrintRpt3()
With Worksheets("Sheet1").PageSetup
.CenterHorizontally = True
.PrintArea = "$A$3:$F$15"
.PrintTitleRows = ("$A$1:$A$2")
.Orientation = xlPortrait
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Worksheets("Sheet1").PrintOut
End Sub



' This is a simple example of using the OnEntry property. The Auto_Open sub calls the Action
' sub. The font is set to bold in the ActiveCell if the value is >= 500. Thus if the value is >=500,
' then ActiveCell.Font.Bold = True. If the value is less than 500, then ActiveCell.Font.Bold = False.
' The Auto_Close sub "turns off" OnEntry.

Sub Auto_Open()
ActiveSheet.OnEntry = "Action"
End Sub


Sub Action()
If IsNumeric(ActiveCell) Then
ActiveCell.Font.Bold = ActiveCell.Value >= 500
End If
End Sub


Sub Auto_Close()
ActiveSheet.OnEntry = ""
End Sub



'These subs place the value (result) of a formula into a cell rather than the formula.

Sub GetSum() ' using the shortcut approach
[A1].Value = Application.Sum([E1:E15])
End Sub

Sub EnterChoice()
Dim DBoxPick As Integer
Dim InputRng As Range
Dim cel As Range
DBoxPick = DialogSheets(1).ListBoxes(1).Value
Set InputRng = Columns(1).Rows

For Each cel In InputRng
If cel.Value = "" Then
cel.Value = Application.Index([InputData!StateList], DBoxPick, 1)
End
End If
Next

End Sub



' To add a range name for known range
Sub AddName1()
ActiveSheet.Names.Add Name:="MyRange1", RefersTo:="=$A$1:$B$10"
End Sub


' To add a range name based on a selection
Sub AddName2()
ActiveSheet.Names.Add Name:="MyRange2", RefersTo:="=" & Selection.Address()
End Sub


' To add a range name based on a selection using a variable. Note: This is a shorter version
Sub AddName3()
Dim rngSelect As String
rngSelect = Selection.Address
ActiveSheet.Names.Add Name:="MyRange3", RefersTo:="=" & rngSelect
End Sub


' To add a range name based on a selection. (The shortest version)
Sub AddName4()
Selection.Name = "MyRange4"
End Sub