VBA Code
Shading Cells
The best way to shade cells is to define the ColorIndex property and assign it to the corresponding colour palette number.
Range("A1:B10").Interior.ColorIndex = 17
Range("A1:B10").Interior.ColorIndex = xlColorIndex.xlColorIndexAutomatic
Range("A1:B10").Interior.ColorIndex = Excel.xlAutomatic
The second line is only made available for backwards compatibility.
objRange.ClearContents 'values and formulas
objRange.Clear 'values, formulas and formatting
objRange.ClearFormats 'clears just formatting (inc conditional formatting)
objRange.ClearNotes
objRange.ClearComments
objRange.ClearOutline
Using Colours
Range("A1:B10").Interior.Color = RGB(153,51,102)
Checking for any shading
If (ActiveCell.Interior.ColorIndex <> xlNone) Then
Removing Shading
Range("A1:B10").Interior.ColorIndex = xlColorIndex.xlColorIndexNone
Range("A1:B10").Interior.ColorIndex = Excel.xlNone
The second line is only made available for backwards compatibility.
Adding Patterns
The default Pattern is solid.
Range("A1:B10").Interior.Pattern = xlPattern.xlSolid
Merging Cells
Range("A1:B1").Merge
Range("A1:B1").MergeCells = True
Also see the Format Dialog Box page
MergeArea Property
Returns a Range object that represents the merged range containing the specified cell
If the specified cell isn't in a merged range, this property returns the specified cell
This property only works on a single cell range
Dim objMergeArea As Range
Set objMergeArea = Range("A3").MergeArea
If objMergeArea.Address = "$A$3" Then
Call MsgBox (not merged")
Else
objMergeArea.Cells(1,1).Value = "hello"
End If
Wrapping Text
Range("A1").WrapText = True
??
Range("A2").Font.Italic = False
Range("D10").Font.Bold = True
Rows(3).Font.Bold = True
Cells(2,4).BorderAround Weight:=xlMedium
ActiveSheet.Rows(5).Font.Size = 10
ActiveSheet.Rows(2:10).Font.Name = "Arial"
The available font size using VBA is 1 to 127 although the formatting toolbar only lists 8 to 72. If you do not have the chosen font installed then Excel will substitute the closest match.
When formatting text, there is a font.fontstyle property but I would not suggest using this. It is better to explicitly specify whether bold, italics etc.
When you change the background or font colour of a cell, Excel does not consider this to be changing the value of the cell and will not generate a Worksheet_Change() event.
Clears the formulas and formatting
objRange.Clear
Application.FindFormat
Application.ReplaceFormat
The Colors property returns or sets the colours defined in the colour palette.
The colour palette has 56 colours.
ActiveWorkbook.Colors(1) = RGB(50, 100, 150)
If the Index property is not specified then the Colors property will return an array containing all 56 colours.
Dim avArray As Variant
avArray = ActiveWorkbook.Colors()
You can quickly reset all the colours in a workbook.
ActiveWorkbook.ResetColors
Format Cells Dialog Box
Number tab
Range.NumberFormat = "@" 'text
Range.NumberFormat = "0" 'no decimal places
Range.NumberFormat = "0.00" 'two decimal places
Range.NumberFormat = "General" 'general
Range.NumberFormat = "0.00%" 'percentage
Application.DecimalSeparator
UseSystemSeparators
Alignment tab
With Selection
.HorizontalAlignment = xlHAlign.xlHAlignGeneral
.VerticalAlignment = xlVAlign.xlVAlignBottom
.AddIndent = False
.IndentLevel = 0 - 15
.WrapText = False
.ShrinkToFit = False
.MergeCells = False
.Orientation = 40
'for some reason this is not an enumeration ?
.ReadingOrder = Excel.Constants.xlRTL
.ReadingOrder = Excel.Constants.xlLTR
.ReadingOrder = Excel.Constants.xlContext
End With
Font tab
The Normal font checkbox just returns all the properties back to the default values.
Some of these properties can also return Nothing (and not just True or False). It is safer to use variant variables when analysing and changing the properties.
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular" '(in C# this does not exist as there are specific properties for Bold and Italic
.Size = 10
.Bold = False
.Underline = xlUnderlineStyle.xlUnderlineStyleNone
.Color = RGB(30,30,30)
'when you select Automatic the color index used is 0
.ColorIndex = xlColorIndex.xlColorIndexAutomatic | 0 | 53
.Strikethrough = False
.Superscript = False
.Subscript = False
'This is true if the font selected in an outline font - This has no effect in Windows
.OutlineFont = False
'This is true if the font selected in an outline font - This has no effect in Windows
.Shadow = False
End With
Border tab
You can use either ColorIndex or Color, but not both.
You can specify both the LineStyle and the Weight. If you do not specify them then the default will be used.
| linestyle=xlNone | linestyle=xlDashDotDot; weight=xlMedium |
| linestyle=xlContinuous; weight=xlHairline | linestyle=xlSlantDashDot; weight=xlMedium |
| linestyle=xlDot; weight=xlThin | linestyle=xlDashDot; weight=xlMedium |
| linestyle=xlDashDotDot; weight=xlThin | linestyle=xlDash; weight=xlMedium |
| linestyle=xlDashDot; weight=xlThin | linestyle=xlContinuous; weight=xlMedium |
| linestyle=xlDash; weight=xlThin | linestyle=xlContinuous; weight=xlThick |
| linestyle=xlContinuous; weight=xlThin | linestyle=xlDouble; weight=xlThick |
Selection.Borders(xlBordersIndex.xlEdgeLeft).LineStyle = xlLineStyle.xlContinuous
Selection.Borders(xlBordersIndex.xlEdgeLeft).Weight = xlBorderWeight.xlThin
Selection.Borders(xlBordersIndex.xlEdgeLeft).ColorIndex = xlColorIndex.xlColorIndexAutomatic | 53
Selection.Borders(xlBordersIndex.xlEdgeLeft).Color = RGB(10,10,10)
Selection.Borders(xlBordersIndex.xlEdgeTop).LineStyle = xlLineStyle.xlContinuous
Selection.Borders(xlBordersIndex.xlEdgeTop).Weight = xlBorderWeight.xlThin
Selection.Borders(xlBordersIndex.xlEdgeTop).ColorIndex = xlColorIndex.xlColorIndexAutomatic | 53
Selection.Borders(xlBordersIndex.xlEdgeBottom).LineStyle = xlLineStyle.xlContinuous
Selection.Borders(xlBordersIndex.xlEdgeBottom).Weight = xlBorderWeight.xlThin
Selection.Borders(xlBordersIndex.xlEdgeBottom).ColorIndex = xlColorIndex.xlColorIndexAutomatic | 53
Selection.Borders(xlBordersIndex.xlEdgeRight).LineStyle = xlLineStyle.xlContinuous
Selection.Borders(xlBordersIndex.xlEdgeRight).Weight = xlBorderWeight.xlThin
Selection.Borders(xlBordersIndex.xlEdgeRight).ColorIndex = xlColorIndex.xlColorIndexAutomatic | 53
You cannot define an InsideVertical border if the Range has no inside vertical borders (i.e. only 1 cell).
Assigning an InsideVertical on a single cell will generate an error.
Selection.Borders(xlBordersIndex.xlInsideVertical).LineStyle = xlLineStyle.xlContinuous
Selection.Borders(xlBordersIndex.xlInsideVertical).Weight = xlBorderWeight.xlThin
Selection.Borders(xlBordersIndex.xlInsideVertical).ColorIndex = xlColorIndex.xlColorIndexAutomatic | 53
You cannot define an InsideHorizontal border if the Range has no inside vertical borders (i.e. only 1 cell).
Assigning an InsideHorizontal on a single cell will generate an error.
Selection.Borders(xlBordersIndex.xlInsideHorizontal).LineStyle = xlLineStyle.xlContinuous
Selection.Borders(xlBordersIndex.xlInsideHorizontal).Weight = xlBorderWeight.xlThin
Selection.Borders(xlBordersIndex.xlInsideHorizontal).ColorIndex = xlColorIndex.xlColorIndexAutomatic | 53
Selection.Borders(xlBordersIndex.xlDiagonalDown).LineStyle = Excel.xlNone
Selection.Borders(xlBordersIndex.xlDiagonalUp).LineStyle = Excel.xlNone
You can also remove all the borders using this single line
Selection.Borders.LineStyle = xlLineStyle.xlLineStyleNone
Fill tab
This was called the Patterns tab in 2003.
Selection.Interior.Color = RGB(120,120,120)
Selection.Interior.ColorIndex = (old 2003)
There is a Patterns property that corresponds to the Patterns tab on this dialog box.
Selection.Interior.Pattern = xlPattern.xlPatternNone
Selection.Interior.Pattern = xlPattern.xlLightDown
The other properties are only relevant when the Interior.Pattern property is not xlPatternNone.
The PatternColorIndex property can be either an index into the current colour palette, or as one of the following xlColorIndex constants
Selection.Interior.PatternColorIndex = 42
This can be used when you don't want a pattern. This is the same as setting the Interior.Pattern property to xlPatternNone
Selection.Interior.PatternColorIndex = xlColorIndex.xlColorIndexNone
This can be used to select the automatic pattern.
Selection.Interior.PatternColorIndex = xlColorIndex.xlColorIndexAutomatic
Selection.Interior.ThemeColor = xlThemeColor.xlThemeColorAccent1
Selection.Interior.TintAndShade = -0.24994659
Selection.Interior.PatternThemeColor = xlThemeColor.xlThemeColorAccent2
Selection.Interior.PatternTintAndShade =
Selection.Interior.Gradient.Degree = 90
Selection.Interior.Gradient.ColorStops.Clear
Selection.Interior.Gradient.ColorStops.Add(0).ThemeColor =
Selection.Interior.Gradient.ColorStops.Add(0).TintAndShade =
Protection tab
Selection.Locked = False
Selection.FormulaHidden = True
Please refer to the Protection section for more details.
Formatting Characters
It is possible to format different parts of a text string with the help of some VBA code.
Lets suppose we want to change the formatting of the following text so the different components are displayed in different colours and formatted differently.
Please note that this method cannot be used to format dates, only text entries.
 |
The following lines of code loop through all the cells and manually change the formatting of each cell.
Range("B2").Select
Do While Len(ActiveCell.Value) > 0
ActiveCell.Characters(Start:=1, Length:=2).Font.ColorIndex = 9
ActiveCell.Characters(Start:=1, Length:=2).Font.Bold = True
ActiveCell.Characters(Start:=4, Length:=2).Font.ColorIndex = 22
ActiveCell.Characters(Start:=4, Length:=2).Font.Italic = True
ActiveCell.Characters(Start:=7, Length:=4).Font.ColorIndex = 49
ActiveCell.Characters(Start:=7, Length:=4).Font.Underline = True
ActiveCell.Offset(1,0).Select
Loop
Delete Unused Custom Formats
This procedure provides a workaround for the glaring lack of accessibility in VBA for manipulating custom number formats.
To do this, it hacks into the Number Format dialog box with SendKeys.
It loops through each item, including those custom number formats that have been orphaned from the worksheet.
The dialog box flickers upon each opening, but it works! If anyone comes up with a way to eliminate the flicker, let me know.
Sub DeleteUnusedCustomNumberFormats()
Dim Buffer As Object
Dim Sh As Object
Dim SaveFormat As Variant
Dim fFormat As Variant
Dim nFormat() As Variant
Dim xFormat As Long
Dim Counter As Long
Dim Counter1 As Long
Dim Counter2 As Long
Dim StartRow As Long
Dim EndRow As Long
Dim Dummy As Variant
Dim pPresent As Boolean
Dim NumberOfFormats As Long
Dim Answer
Dim c As Object
Dim DataStart As Long
Dim DataEnd As Long
Dim AnswerText As String
NumberOfFormats = 1000
ReDim nFormat(0 To NumberOfFormats)
AnswerText = "Do you want to delete unused custom formats from the workbook?"
AnswerText = AnswerText & Chr(10) & "To get a list of used and unused formats only, choose No."
Answer = MsgBox(AnswerText, 259)
If Answer = vbCancel Then GoTo Finito
On Error GoTo ErrorHandler
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "CustomFormats"
Worksheets("CustomFormats").Activate
Set Buffer = Range("A2")
Buffer.Select
nFormat(0) = Buffer.NumberFormatLocal
Counter = 1
Do
SaveFormat = Buffer.NumberFormatLocal
Dummy = Buffer.NumberFormatLocal
DoEvents
SendKeys "{tab 3}{down}{enter}"
Application.Dialogs(xlDialogFormatNumber).Show Dummy
nFormat(Counter) = Buffer.NumberFormatLocal
Counter = Counter + 1
Loop Until nFormat(Counter - 1) = SaveFormat
ReDim Preserve nFormat(0 To Counter - 2)
Range("A1").Value = "Custom formats"
Range("B1").Value = "Formats used in workbook"
Range("C1").Value = "Formats not used"
Range("A1:C1").Font.Bold = True
StartRow = 3
EndRow = 16384
For Counter = 0 To UBound(nFormat)
Cells(StartRow, 1).Offset(Counter, 0).NumberFormatLocal = nFormat(Counter)
Cells(StartRow, 1).Offset(Counter, 0).Value = nFormat(Counter)
Next Counter
Counter = 0
For Each Sh In ActiveWorkbook.Worksheets
If Sh.Name = "CustomFormats" Then Exit For
For Each c In Sh.UsedRange.Cells
fFormat = c.NumberFormatLocal
If Application.WorksheetFunction.CountIf(Range(Cells(StartRow, 2), Cells(EndRow, 2)), fFormat) = 0 Then
Cells(StartRow, 2).Offset(Counter, 0).NumberFormatLocal = fFormat
Cells(StartRow, 2).Offset(Counter, 0).Value = fFormat
Counter = Counter + 1
End If
Next c
Next Sh
xFormat = Range(Cells(StartRow, 2), Cells(EndRow, 2)).Find("").Row - 2
Counter2 = 0
For Counter = 0 To UBound(nFormat)
pPresent = False
For Counter1 = 1 To xFormat
If nFormat(Counter) = Cells(StartRow, 2).Offset(Counter1, 0).NumberFormatLocal Then
pPresent = True
End If
Next Counter1
If pPresent = False Then
Cells(StartRow, 3).Offset(Counter2, 0).NumberFormatLocal = nFormat(Counter)
Cells(StartRow, 3).Offset(Counter2, 0).Value = nFormat(Counter)
Counter2 = Counter2 + 1
End If
Next Counter
With ActiveSheet.Columns("A:C")
.AutoFit
.HorizontalAlignment = xlLeft
End With
If Answer = vbYes Then
DataStart = Range(Cells(1, 3), Cells(EndRow, 3)).Find("").Row + 1
DataEnd = Cells(DataStart, 3).Resize(EndRow, 1).Find("").Row - 1
On Error Resume Next
For Each c In Range(Cells(DataStart, 3), Cells(DataEnd, 3)).Cells
ActiveWorkbook.DeleteNumberFormat (c.NumberFormat)
Next c
End If
ErrorHandler:
Set c = Nothing
Set Sh = Nothing
Set Buffer = Nothing
End Sub
Public Sub ListAllFormats()
Dim iwshcount As Integer
Dim objWorksheet As Worksheet
Dim llastrow As Long
Dim ilastcolumn As Integer
Dim lRowNo As Long
Dim icolno As Integer
Dim arUniqueFormats2() As String
Dim objFSODictionary As Scripting.Dictionary
Dim objFSOUniqueTotals As Scripting.Dictionary
Dim objFSOWorksheetNames_Column As Scripting.Dictionary
Dim arUniqueWorksheetKeys As Variant
Dim snumberformat As String
Dim isheetandformatcount As Integer
Dim lcurrentrow As Long
Dim scellpattern As String
Dim scellstyle As String
Dim slastcolchar As String
On Error GoTo AnError
ReDim arUniqueFormats2(4, (3000 * ActiveWorkbook.Worksheets.Count)) As String
Set objFSODictionary = New Scripting.Dictionary
Set objFSOUniqueTotals = New Scripting.Dictionary
Set objFSOWorksheetNames_Column = New Scripting.Dictionary
For iwshcount = 1 To ActiveWorkbook.Worksheets.Count
Set objWorksheet = ActiveWorkbook.Worksheets(iwshcount)
If (objWorksheet.Name <> "Sheet1") Then
If (objWorksheet.Visible <> xlSheetVisible) Then
objWorksheet.Visible = xlSheetVisible
End If
If (objFSOWorksheetNames_Column.Exists(objWorksheet.Name) = False) Then
objFSOWorksheetNames_Column.Add objWorksheet.Name, iwshcount - 1
End If
objWorksheet.Select
llastrow = Range("A1").SpecialCells(XlCellType.xlCellTypeLastCell).Row
ilastcolumn = Range("A1").SpecialCells(XlCellType.xlCellTypeLastCell).Column
For lRowNo = 1 To llastrow
For icolno = 1 To ilastcolumn
snumberformat = Cells(lRowNo, icolno).NumberFormatLocal
Call UniqueFormatsPopulate("Number Format", snumberformat, lRowNo, icolno, objWorksheet.Name, _
objFSODictionary, objFSOUniqueTotals, arUniqueFormats2)
scellpattern = Cells(lRowNo, icolno).Interior.ColorIndex
Call UniqueFormatsPopulate("Shading Pattern", scellpattern, lRowNo, icolno, objWorksheet.Name, _
objFSODictionary, objFSOUniqueTotals, arUniqueFormats2)
scellstyle = Cells(lRowNo, icolno).Style
Call UniqueFormatsPopulate("Style", scellstyle, lRowNo, icolno, objWorksheet.Name, _
objFSODictionary, objFSOUniqueTotals, arUniqueFormats2)
Next icolno
Next lRowNo
End If
Next iwshcount
ReDim Preserve arUniqueFormats2(4, objFSOUniqueTotals.Count - 1)
arUniqueFormats2 = SortArray(arUniqueFormats2)
Worksheets("Sheet1").Select
Cells.Clear
Cells.ClearFormats
'display worksheets across the top
Range("C2").Value = "TOTAL"
arUniqueWorksheetKeys = objFSOWorksheetNames_Column.Keys()
For iwshcount = 0 To UBound(arUniqueWorksheetKeys, 1)
Cells(2, 4 + iwshcount).Value = arUniqueWorksheetKeys(iwshcount)
Next iwshcount
slastcolchar = Col_Letter(UBound(arUniqueWorksheetKeys, 1) + 4)
'display unique formats down left hand side - start by creating a list of unique formats
llastrow = 3
llastrow = PopulateTableWithCategory(slastcolchar, objFSODictionary, objFSOWorksheetNames_Column, arUniqueFormats2, "Number Format", llastrow)
llastrow = llastrow + 2
llastrow = PopulateTableWithCategory(slastcolchar, objFSODictionary, objFSOWorksheetNames_Column, arUniqueFormats2, "Shading Pattern", llastrow)
llastrow = llastrow + 2
llastrow = PopulateTableWithCategory(slastcolchar, objFSODictionary, objFSOWorksheetNames_Column, arUniqueFormats2, "Style", llastrow)
Exit Sub
AnError:
MsgBox (Err.Number & " - " & Err.Description)
End Sub
'**************************************************************************************
Public Sub UniqueFormatsPopulate(ByVal sCategoryName As String, _
ByVal sFormat As String, _
ByVal lRowNo As Long, _
ByVal icolno As Integer, _
ByVal sWshName As String, _
ByRef objFSODictionary As Scripting.Dictionary, _
ByRef objFSOUniqueTotals As Scripting.Dictionary, _
ByRef arUniqueFormats As Variant)
On Error GoTo AnError
If (objFSODictionary.Exists(sCategoryName & sWshName & "!!" & sFormat) = True) Then
objFSODictionary(sCategoryName & sWshName & "!!" & sFormat) = _
objFSODictionary(sCategoryName & sWshName & "!!" & sFormat) + 1
arUniqueFormats(3, objFSOUniqueTotals(sCategoryName & sWshName & "!!" & sFormat)) = _
arUniqueFormats(3, objFSOUniqueTotals(sCategoryName & sWshName & "!!" & sFormat)) & "-" & Cells(lRowNo, icolno).Address
Else
objFSODictionary.Add sCategoryName & sWshName & "!!" & sFormat, 1
objFSOUniqueTotals.Add sCategoryName & sWshName & "!!" & sFormat, (objFSOUniqueTotals.Count)
arUniqueFormats(0, objFSOUniqueTotals.Count - 1) = sCategoryName
arUniqueFormats(1, objFSOUniqueTotals.Count - 1) = sWshName
arUniqueFormats(2, objFSOUniqueTotals.Count - 1) = sFormat
arUniqueFormats(3, objFSOUniqueTotals.Count - 1) = Cells(lRowNo, icolno).Address
arUniqueFormats(4, objFSOUniqueTotals.Count - 1) = sCategoryName & sWshName & sFormat
End If
Exit Sub
AnError:
MsgBox (Err.Number & " - " & Err.Description)
End Sub
'**************************************************************************************
Public Function PopulateTableWithCategory(ByVal slastcolchar As String, _
ByVal objFSODictionary As Scripting.Dictionary, _
ByVal objFSOWorksheetNames_Column As Scripting.Dictionary, _
ByVal arUniqueFormats As Variant, _
ByVal sCategory As String, _
ByVal llastrow As Long) As Long
Dim objFSOUniqueFormats_Rows As Scripting.Dictionary
Dim arUniqueFormatKeys As Variant
Dim lRowNo As Long
On Error GoTo AnError
Set objFSOUniqueFormats_Rows = New Scripting.Dictionary
Set objFSOUniqueFormats_Rows = ReturnUniqueFormatsForACategory(arUniqueFormats, sCategory)
arUniqueFormatKeys = objFSOUniqueFormats_Rows.Keys
For lRowNo = 0 To UBound(arUniqueFormatKeys, 1)
Range("A" & lRowNo + llastrow).Value = sCategory
Range("B" & lRowNo + llastrow).Value = "''" & arUniqueFormatKeys(lRowNo)
Range("C" & lRowNo + llastrow).Value = "=SUM(D" & lRowNo + llastrow & ":" & _
slastcolchar & lRowNo + llastrow & ")"
If (sCategory = "Shading Pattern") Then
If (arUniqueFormatKeys(lRowNo) <> "-4142") Then
Range("B" & lRowNo + llastrow).Interior.ColorIndex = arUniqueFormatKeys(lRowNo)
End If
End If
Next lRowNo
Rows("2:2").Font.Bold = True
Columns("B:C").Font.Bold = True
'Columns("A").ColumnWidth = 3
Columns("A:B").EntireColumn.AutoFit
For lRowNo = 0 To UBound(arUniqueFormats, 2)
If (arUniqueFormats(0, lRowNo) = sCategory) Then
Cells((llastrow - 1) + objFSOUniqueFormats_Rows.Item(arUniqueFormats(2, lRowNo)), _
3 + objFSOWorksheetNames_Column.Item(arUniqueFormats(1, lRowNo))).Value = _
objFSODictionary(sCategory & arUniqueFormats(1, lRowNo) & "!!" & arUniqueFormats(2, lRowNo))
End If
Next lRowNo
PopulateTableWithCategory = llastrow + UBound(arUniqueFormatKeys, 1)
Exit Function
AnError:
MsgBox (Err.Number & " - " & Err.Description)
End Function
'**************************************************************************************
Public Function ReturnUniqueFormatsForACategory(ByVal arUniqueFormats As Variant, _
ByVal sCategory As String) As Scripting.Dictionary
Dim lRowNo As Long
Dim icolno As Integer
Dim objFSOUniqueFormats As Scripting.Dictionary
On Error GoTo AnError
Set objFSOUniqueFormats = New Scripting.Dictionary
icolno = 1
For lRowNo = 0 To UBound(arUniqueFormats, 2)
If (arUniqueFormats(0, lRowNo) = sCategory) Then
If (objFSOUniqueFormats.Exists(arUniqueFormats(2, lRowNo)) = False) Then
objFSOUniqueFormats.Add arUniqueFormats(2, lRowNo), icolno
icolno = icolno + 1
End If
End If
Next lRowNo
Set ReturnUniqueFormatsForACategory = objFSOUniqueFormats
Exit Function
AnError:
MsgBox (Err.Number & " - " & Err.Description)
End Function
'**************************************************************************************
Public Function SortArray(ByVal arArray As Variant) As Variant
Dim Temp As Variant
Dim i As Long
Dim j As Long
ReDim Temp(4) As String
On Error GoTo AnError
For i = LBound(arArray, 2) To (UBound(arArray, 2) - 1)
For j = (i + 1) To (UBound(arArray, 2))
If arArray(4, i) > arArray(4, j) Then
Temp(0) = arArray(0, j)
Temp(1) = arArray(1, j)
Temp(2) = arArray(2, j)
Temp(3) = arArray(3, j)
Temp(4) = arArray(4, j)
arArray(0, j) = arArray(0, i)
arArray(1, j) = arArray(1, i)
arArray(2, j) = arArray(2, i)
arArray(3, j) = arArray(3, i)
arArray(4, j) = arArray(4, i)
arArray(0, i) = Temp(0)
arArray(1, i) = Temp(1)
arArray(2, i) = Temp(2)
arArray(3, i) = Temp(3)
arArray(4, i) = Temp(4)
End If
Next j
Next i
SortArray = arArray
Exit Function
AnError:
MsgBox (Err.Number & " - " & Err.Description)
End Function
'**************************************************************************************
Public Function Col_Letter(ByVal icolno As Integer) As String
Dim inumber1 As Integer
On Error GoTo AnError
Select Case icolno
Case 0: Col_Letter = Chr(90)
Case Is <= 26: Col_Letter = Chr(icolno + 64)
Case Else
inumber1 = Int((64 + ((icolno - 1) / 26)))
Col_Letter = Chr(inumber1) & Chr(((icolno - 1) Mod 26) + 65)
End Select
Exit Function
AnError:
Call MsgBox("Unable to return the corresponding letter for the column number " & _
"'" & icolno & "'.")
End Function
Public Sub DeleteUnusedCustomNumberFormats() Dim aFormatsArray() As Variant Dim lRowLast_A As Long, lRowLast_B As Long, lRowLast_C As Long, lRowLast_D As Long Dim larraycount As Long, lCounter As Long, linside As Long, lrowno As Long, lTotalRemoved As Long Dim wsh As Excel.Worksheet Dim sFormat As String Dim cell As Excel.Range Dim bExists As Boolean
On Error GoTo ErrorHandler
If (AskForConfirmation = False) Then Exit Sub
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "CustomFormats"
Worksheets("CustomFormats").Activate
'------------------ formats available
aFormatsArray = GetListOfNumberFormats(Range("A2"), False)
For larraycount = 0 To UBound(aFormatsArray)
Worksheets("CustomFormats").Range("A" & larraycount + 2).Value = aFormatsArray(larraycount)
Next larraycount
lRowLast_A = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("A5000").End(XlDirection.xlUp).Address).Row
Worksheets("CustomFormats").Range("A2:A" & lRowLast_A).Sort _
Key1:=Worksheets("CustomFormats").Range("A2"), Order1:=xlAscending
'------------------ formats used
lCounter = 0
For Each wsh In ActiveWorkbook.Worksheets
If wsh.Name = "CustomFormats" Then Exit For
For Each cell In wsh.UsedRange.Cells
sFormat = cell.NumberFormatLocal
If Application.WorksheetFunction.CountIf(Worksheets("CustomFormats").Range("B:B"), sFormat) = 0 Then
Worksheets("CustomFormats").Range("B" & lCounter + 2).NumberFormatLocal = sFormat
Worksheets("CustomFormats").Range("B" & lCounter + 2).Value = sFormat
lCounter = lCounter + 1
End If
Next cell
Next wsh
lRowLast_B = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("B5000").End(XlDirection.xlUp).Address).Row
Worksheets("CustomFormats").Range("B2:B" & lRowLast_B).Sort _
Key1:=Worksheets("CustomFormats").Range("B2"), Order1:=xlAscending
'------------------ formats not used - those in red are not even valid formats
lRowLast_A = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("A5000").End(XlDirection.xlUp).Address).Row
lRowLast_B = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("B5000").End(XlDirection.xlUp).Address).Row
For lrowno = 2 To lRowLast_A
If (FormatIsFound(lRowLast_B, Worksheets("CustomFormats").Range("A" & lrowno).Value) = False) Then
Worksheets("CustomFormats").Range("C" & lCounter + 2).Value = _
Worksheets("CustomFormats").Range("A" & lrowno).Value
If (Worksheets("CustomFormats").Range("A" & lrowno).Value = 0) Then
Worksheets("CustomFormats").Range("C" & lCounter + 2).NumberFormatLocal = _
Worksheets("CustomFormats").Range("A" & lrowno).NumberFormatLocal
Else
If (ApplyNumberFormat(Worksheets("CustomFormats").Range("C" & lCounter + 2), _
Worksheets("CustomFormats").Range("A" & lrowno).Value) = False) Then
Worksheets("CustomFormats").Range("C" & lCounter + 2).Interior.Color = RGB(255, 91, 91)
End If
Worksheets("CustomFormats").Range("C" & lCounter + 2).NumberFormatLocal = "General"
End If
lCounter = lCounter + 1
End If
Next lrowno
lRowLast_C = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("C5000").End(XlDirection.xlUp).Address).Row
Worksheets("CustomFormats").Range("C2:C" & lRowLast_C).Sort _
Key1:=Worksheets("CustomFormats").Range("C2"), Order1:=xlAscending
'------------------ formats removed
lRowLast_C = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("C5000").End(XlDirection.xlUp).Address).Row
For lrowno = 2 To lRowLast_C
If (DeleteNumberFormat(Range("C" & lrowno).Value) = True) Then
Range("D" & lTotalRemoved + 2).Value = Range("C" & lrowno).Value
lTotalRemoved = lTotalRemoved + 1
Else
If (Range("C" & lrowno).Interior.Color <> RGB(255, 91, 91)) Then
Range("C" & lrowno).Interior.Color = RGB(146, 208, 80)
End If
End If
Next lrowno
lRowLast_D = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("D5000").End(XlDirection.xlUp).Address).Row
Worksheets("CustomFormats").Range("D2:D" & lRowLast_D).Sort _
Key1:=Worksheets("CustomFormats").Range("D2"), Order1:=xlAscending
Range("A1").Value = "Formats available"
Range("B1").Value = "Formats used"
Range("C1").Value = "Formats not used"
Range("D1").Value = "Formats removed"
Range("A1:D1").Font.Bold = True
Columns("A:D").ColumnWidth = 35
Columns("A:D").HorizontalAlignment = xlLeft
Range("A2").Select
ActiveWindow.FreezePanes = True
Call ConfirmRemoval(lTotalRemoved)
Set wsh = Nothing
Exit Sub
ErrorHandler:
Set wsh = Nothing
Call MsgBox(Err.Description)
End Sub
Private Function ApplyNumberFormat(ByVal oRange As Excel.Range, _
ByVal sNumberFormat As String) As Boolean
On Error GoTo ErrorHandler:
oRange.NumberFormatLocal = sNumberFormat
ApplyNumberFormat = True
Exit Function
ErrorHandler:
ApplyNumberFormat = False
End Function
Private Function FormatIsFound(ByVal lRowLast As Long, _
ByVal sNumberFormat As String) As Boolean Dim svalue As String
On Error GoTo ErrorHandler:
svalue = Application.WorksheetFunction.Match(sNumberFormat, _
Worksheets("CustomFormats").Range("B2:B" & lRowLast), 0)
FormatIsFound = True
Exit Function
ErrorHandler:
FormatIsFound = False
End Function
Private Function DeleteNumberFormat(ByVal sNumberFormat As String) As Boolean
On Error GoTo ErrorHandler:
Call ActiveWorkbook.DeleteNumberFormat(sNumberFormat)
DeleteNumberFormat = True
Exit Function
ErrorHandler:
DeleteNumberFormat = False
End Function
Private Function AskForConfirmation() As Boolean Dim iResult As VBA.VbMsgBoxResult
iResult = MsgBox("Do you want to delete unused custom formats from the workbook?", vbYesNo + vbQuestion)
If (iResult = vbNo) Then AskForConfirmation = False
If (iResult = vbYes) Then AskForConfirmation = True End Function
Private Sub ConfirmRemoval(ByVal lTotalRemoved As Long)
Call MsgBox( _
"'" & lTotalRemoved & "' number formats have been removed." & _
vbCrLf & vbCrLf & _
"The new 'CustomFormats' worksheet provides more information." & _
vbCrLf & vbCrLf & _
"The number formats that have been removed have been shaded in column 'C'.", _
vbInformation + vbOKOnly)
End Sub
Private Function GetListOfNumberFormats(ByVal oRange As Excel.Range, _
Optional ByVal bFromWorksheet As Boolean = False) As Variant Dim aFormatsArray() As Variant Dim sFormat As String, sSaveFormat As String Dim lCounter As Long, lRowLast As Long, lrowno As Long
On Error GoTo ErrorHandler:
ReDim aFormatsArray(0 To 2000)
If (bFromWorksheet = True) Then
lRowLast = Worksheets("CustomFormats").Range( _
Worksheets("CustomFormats").Range("A5000").End(XlDirection.xlUp).Address).Row
For lrowno = 2 To lRowLast
aFormatsArray(lrowno - 2) = Worksheets("CustomFormats").Range("A" & lrowno).Value
Next lrowno
lCounter = lrowno - 1
Else
oRange.Select
aFormatsArray(0) = oRange.NumberFormatLocal
lCounter = 1
Do
sSaveFormat = oRange.NumberFormatLocal
sFormat = oRange.NumberFormatLocal
VBA.DoEvents
SendKeys "{tab 3}{down}{enter}"
Application.Dialogs(xlDialogFormatNumber).Show sFormat
aFormatsArray(lCounter) = Range("A2").NumberFormatLocal
lCounter = lCounter + 1
Loop Until aFormatsArray(lCounter - 1) = sSaveFormat
End If
ReDim Preserve aFormatsArray(0 To lCounter - 2)
GetListOfNumberFormats = aFormatsArray
Exit Function
ErrorHandler:
Call MsgBox(Err.Message)
End Function
Remove Excess Shading
Sub ClearExcessRowsAndColumns()
Dim ar As Range
Dim r As Double
Dim c As Double
Dim tr As Double
Dim tc As Double
Dim wksWks As Worksheet
Dim ur As Range
Dim arCount As Integer
Dim i As Integer
Dim blProtCont As Boolean
Dim blProtScen As Boolean
Dim blProtDO As Boolean
Dim shp As Shape
On Error GoTo ErrorHandler
' Application.ScreenUpdating = False
For Each wksWks In ActiveWorkbook.Worksheets
Err.Clear
'Store worksheet protection settings and unprotect if protected.
blProtCont = wksWks.ProtectContents
blProtDO = wksWks.ProtectDrawingObjects
blProtScen = wksWks.ProtectScenarios
wksWks.Unprotect ""
If Err.Number = 1004 Then
Err.Clear
MsgBox "'" & wksWks.Name & "' is protected with a password and cannot be checked.", vbInformation
Else
Application.StatusBar = "Checking " & wksWks.Name & ", Please Wait..."
r = 0
c = 0
'Determine if the sheet contains both formulas and constants
Set ur = Union(wksWks.UsedRange.SpecialCells(xlCellTypeConstants), wksWks.UsedRange.SpecialCells(xlCellTypeFormulas))
'If both fails, try constants only
If Err.Number = 1004 Then
Err.Clear
Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeConstants)
End If
'If constants fails then set it to formulas
If Err.Number = 1004 Then
Err.Clear
Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeFormulas)
End If
'If there is still an error then the worksheet is empty
If Err.Number <> 0 Then
Err.Clear
If wksWks.UsedRange.Address <> "$A$1" Then
ur.EntireRow.Delete
Else
Set ur = Nothing
End If
End If
'On Error GoTo 0
If Not ur Is Nothing Then
arCount = ur.Areas.Count
'determine the last column and row that contains data or formula
For Each ar In ur.Areas
i = i + 1
tr = ar.Range("A1").Row + ar.Rows.Count - 1
tc = ar.Range("A1").Column + ar.Columns.Count - 1
If tc > c Then c = tc
If tr > r Then r = tr
Next
'Determine the area covered by shapes
'so we don't remove shading behind shapes
For Each shp In wksWks.Shapes
tr = shp.BottomRightCell.Row
tc = shp.BottomRightCell.Column
If tc > c Then c = tc
If tr > r Then r = tr
Next
Application.StatusBar = "Clearing Excess Cells in " & wksWks.Name & ", Please Wait..."
Set ur = wksWks.Rows(r + 1 & ":" & wksWks.Rows.Count)
'Reset row height which can also cause the lastcell to be innacurate
ur.EntireRow.RowHeight = wksWks.StandardHeight
ur.Clear
Set ur = wksWks.Columns(ColLetter(c + 1) & ":" & ColLetter(wksWks.Columns.Count))
'Reset column width which can also cause the lastcell to be innacurate
ur.EntireColumn.ColumnWidth = wksWks.StandardWidth
ur.Clear
End If
End If
'Reset protection.
wksWks.Protect "", blProtDO, blProtCont, blProtScen
Err.Clear
Next
Application.StatusBar = False
' Application.SendKeys "%(oe)~{TAB}~"
Application.CommandBars.ExecuteMso "PicturesCompress"
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
End Sub
Styles
Styles apply to a single workbook and cannot be easily transferred to other workbooks.
Selection.Style = "Normal"
ActiveWorkbook.Styles.Add(Name:="your style name")
ActiveWorkBook.Styles("your style name").Font.Name = "Arial"
Public Sub DeleteStyles()
Dim objStyle As Style
Dim iReturn As Integer
For Each objStyle In ActiveWorkbook.Styles
If (objStyle.BuiltIn = False) Then
iReturn = MsgBox("Do you want to delete this style: """ & objStyle.Name & """ ?", vbYesNo)
If (iReturn = vbYes) Then
objStyle.Delete
End If
End If
Next objStyle
End Sub
AutoFormat
objRange.AutoFormat.Format:=xlRangeAutoFormatNone, _
Number:=True
Font:=True
Alignment:=
Border:=True
Pattern:=True
Width:=
Themes
ActiveWorkbook.Theme.ThemeColorScheme.Load("C:\temp\mytheme.xml")
Debug.Print ActiveWorkbook.Theme.ThemeFontScheme.MajorFont(msoFontLanguageIndex.msoThemeLatin).Name
Debug.Print ActiveWorkbook.Theme.ThemeFontScheme.MinorFont(msoFontLanguageIndex.msoThemeLatin).Name
Text To Columns
Parses a column of cells that contain text into several columns.
expression.TextToColumns(Destination, _
DataType:=xlTextParsingType.xlDemilited, _
TextQualifier:=xlTextQualifier.xlTextQualifierDoubleQuote, _
ConsecutiveDelimiter, _
Tab, _
Semicolon, _
Comma, _
Space, _
Other, _
OtherChar, _
FieldInfo:=xlColumnDataType., _
DecimalSeparator, _
ThousandsSeparator, _
TrailingMinusNumbers)
expression - Required.
Destination - Optional Variant. A Range object that specifies where Microsoft Excel will place the results. If the range is larger than a single cell, the top left cell is used.
ConsecutiveDelimiter - Optional Variant. True to have Microsoft Excel consider consecutive delimiters as one delimiter. The default value is False.
Tab - Optional Variant. True to have DataType be xlDelimited and to have the tab character be a delimiter. The default value is False.
Semicolon - Optional Variant. True to have DataType be xlDelimited and to have the semicolon be a delimiter. The default value is False.
Comma - Optional Variant. True to have DataType be xlDelimited and to have the comma be a delimiter. The default value is False.
Space - Optional Variant. True to have DataType be xlDelimited and to have the space character be a delimiter. The default value is False.
Other - Optional Variant. True to have DataType be xlDelimited and to have the character specified by the OtherChar argument be a delimiter. The default value is False.
OtherChar - Optional Variant (required if Other is True). The delimiter character when Other is True. If more than one character is specified, only the first character of the string is used; the remaining characters are ignored.
FieldInfo - Optional Variant. An array containing parse information for the individual columns of data. The interpretation depends on the value of DataType. When the data is delimited, this argument is an array of two-element arrays, with each two-element array specifying the conversion options for a particular column. The first element is the column number (1-based), and the second element is one of the constants specifying how the column is parsed.
The column specifiers can be in any order. If a given column specifier is not present for a particular column in the input data, the column is parsed with the General setting. This example causes the third column to be skipped, the first column to be parsed as text, and the remaining columns in the source data to be parsed with the General setting.
Array(Array(3, 9), Array(1, 2))
If the source data has fixed-width columns, the first element of each two-element array specifies the starting character position in the column (as an integer; 0 (zero) is the first character). The second element of the two-element array specifies the parse option for the column as a number from 1 through 9, as listed above.
The following example parses two columns from a fixed-width file, with the first column starting at the beginning of the line and extending for 10 characters. The second column starts at position 15 and goes to the end of the line. To avoid including the characters between position 10 and position 15, Microsoft Excel adds a skipped column entry.
Array(Array(0, 1), Array(10, 9), Array(15, 1))
DecimalSeparator Optional String. The decimal separator that Microsoft Excel uses when recognizing numbers. The default setting is the system setting.
ThousandsSeparator Optional String. The thousands separator that Excel uses when recognizing numbers. The default setting is the system setting.
TrailingMinusNumbers Optional Variant. Numbers that begin with a minus character.
Example
This example converts the contents of the Clipboard, which contains a space-delimited text table, into separate columns on Sheet1. You can create a simple space-delimited table in Notepad or WordPad (or another text editor), copy the text table to the Clipboard, switch to Microsoft Excel, and then run this example.
Worksheets("Sheet1").Activate
ActiveSheet.Paste
Selection.TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, Space:=True
Application.DisplayPageBreaks
This property controls if page breaks (both automatic and manual) on the specified worksheet are displayed.
Application.PrintCommunication = False
This was added in Excel 2010
ActiveSheet.PageSetup.
Means the printer is only contacted once
Displaying the Workbook in Print Preview
ActiveWorkBook.PrintPreview
Displaying the Workbook in Page Break View
ActiveWindow.View = xlPageBreakPreview
ActiveWindow.View = xlNormalView
PageSetup Object
Represents the page setup description. The PageSetup object contains all page setup attributes (left margin, bottom margin, paper size, and so on) as properties.
Using the PageSetup Object
Use the PageSetup property to return a PageSetup object. The following example sets the orientation to landscape mode and then prints the worksheet.
With Worksheets("Sheet1")
.PageSetup.Orientation = xlLandscape
.PrintOut
End With
PrintPreview Method
Shows a preview of the object as it would look when printed.
This example displays Sheet1 in print preview.
Worksheets("Sheet1").PrintPreview
PrintArea Property
Returns or sets the range to be printed, as a string using A1-style references in the language of the macro. Read/write String.
Set this property to False or to the empty string ("") to set the print area to the entire sheet.
This property applies only to worksheet pages.
This example sets the print area to cells A1:C5 on Sheet1.
Worksheets("Sheet1").PageSetup.PrintArea = "$A$1:$C$5"
This example sets the print area to the current region on Sheet1. Note that you use the Address property to return an A1-style address.
Worksheets("Sheet1").Activate
ActiveSheet.PageSetup.PrintArea = ActiveCell.CurrentRegion.Address
PrintOut Method
expression.PrintOut( [ From, To, Copies, Preview, ActivePrinter, PrintToFile, Collate, PrToFileName ])
expression Required. An expression that returns an object in the Applies To list.
From - (Variant) The number of the page at which to start printing. If this argument is omitted, printing starts at the beginning.
To - (Variant) The number of the last page to print. If this argument is omitted, printing ends with the last page.
Copies (Variant) The number of copies to print. If this argument is omitted, one copy is printed.
Preview (Variant) True to have Microsoft Excel invoke print preview before printing the object. False (or omitted) to print the object immediately.
ActivePrinter (Variant) Sets the name of the active printer.
PrintToFile (Variant) True to print to a file. If PrToFileName is not specified, Microsoft Excel prompts the user to enter the name of the output file.
Collate (Variant) True to collate multiple copies.
PrToFileName (Variant) If PrintToFile is set to True, this argument specifies the name of the file you want to print to.
BeforePrint Event
Include the folder path and workbook name in a header
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim objwsh As Worksheet
For Each objwsh In ThisWorkbook.Sheets
objwsh.PageSetup.LeftHeader = ThisWorkbook.FullName
Next objwsh
End Sub
Remarks
Pages in the descriptions of From and To refers to printed pages - not overall pages in the sheet or workbook.
This example prints the active sheet.
ActiveSheet.PrintOut
Printing a Workbook
Workbooks("Book2.xls").PrintOut
ThisWorkbook.PrintOut(From, To, Copies)
Printing to a File
ActiveSheet.PrintOut PrintToFile:=Time, PrToFileName:="name of file.prn" 'Printing to a file
Print to a network printer
The example macros below shows how to get the full network printer name (useful when the network printer name can change) and print a worksheet to this printer:
Sub PrintToNetworkPrinterExample()
Dim strCurrentPrinter As String, strNetworkPrinter As String
strNetworkPrinter = GetFullNetworkPrinterName("HP LaserJet 8100 Series PCL")
If Len(strNetworkPrinter) > 0 Then ' found the network printer
strCurrentPrinter = Application.ActivePrinter
' change to the network printer
Application.ActivePrinter = strNetworkPrinter
Worksheets(1).PrintOut ' print something
' change back to the previously active printer
Application.ActivePrinter = strCurrentPrinter
End If
End Sub
Function GetFullNetworkPrinterName(strNetworkPrinterName As String) As String
' returns the full network printer name
' returns an empty string if the printer is not found
' e.g. GetFullNetworkPrinterName("HP LaserJet 8100 Series PCL")
' might return "HP LaserJet 8100 Series PCL on Ne04:"
Dim strCurrentPrinterName As String, strTempPrinterName As String, i As Long
strCurrentPrinterName = Application.ActivePrinter
i = 0
Do While i < 100
strTempPrinterName = strNetworkPrinterName & " on Ne" & Format(i, "00") & ":"
On Error Resume Next ' try to change to the network printer
Application.ActivePrinter = strTempPrinterName
On Error GoTo 0
If Application.ActivePrinter = strTempPrinterName Then
' the network printer was found
GetFullNetworkPrinterName = strTempPrinterName
i = 100 ' makes the loop end
End If
i = i + 1
Loop
' remove the line below if you want the function to change the active printer
Application.ActivePrinter = strCurrentPrinterName ' change back to the original printer
End Function
Change the default printer
This example macro shows how to print a selected document to another printer then the default printer. This is done by changing the property Application.ActivePrinter:
Sub PrintToAnotherPrinter()
Dim strCurrentPrinter As String
strCurrentPrinter = Application.ActivePrinter ' store the current active printer
On Error Resume Next ' ignore printing errors
Application.ActivePrinter = "microsoft fax on fax:" ' change to another printer
ActiveSheet.PrintOut ' print the active sheet
Application.ActivePrinter = strCurrentPrinter ' change back to the original printer
On Error Goto 0 ' resume normal error handling
End Sub
Identify Default Printer
Private Declare Function GetProfileStringA Lib "kernel32" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Sub DefaultPrinterInfo()
Dim strLPT As String * 255
Dim Result As String
Call GetProfileStringA _
("Windows", "Device", "", strLPT, 254)
Result = Application.Trim(strLPT)
ResultLength = Len(Result)
Comma1 = Application.Find(",", Result, 1)
Comma2 = Application.Find(",", Result, Comma1 + 1)
' Gets printer's name
Printer = Left(Result, Comma1 - 1)
' Gets driver
Driver = Mid(Result, Comma1 + 1, Comma2 - Comma1 - 1)
' Gets last part of device line
Port = Right(Result, ResultLength - Comma2)
' Build message
Msg = "Printer:" & Chr(9) & Printer & Chr(13)
Msg = Msg & "Driver:" & Chr(9) & Driver & Chr(13)
Msg = Msg & "Port:" & Chr(9) & Port
' Display message
MsgBox Msg, vbInformation, "Default Printer Information"
End Sub
Printing to PDF
Range("B2:O37").PrintOut
ActiveWorkbook.ExportAsFixedFormat
ActiveSheet.ExportAsFixedFormat _
Dim cht As Chart
Set cht = ws.ChartObjects("Chart 1").Chart
cht.ExportAsFixedFormat
Saving a Range as PDF
Private Sub Range_SaveAsPDF
Call Range.ExportAsFixedFormat( _
Type:=xlFixedFormatType.xlTypePDF, _
Filename:="C:\Temp\FileName", _
Quality:=xlFixedFormatQuality.xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True)
End Sub
Type - Can be either xlTypePDF or xlTypeXPS
Filename - A string that indicates the name of the file to be saved. You can include a full path, or Excel saves the file in the current folder.
Quality - Can be set to either xlQualityStandard or xlQualityMinimum.
IncludeDocProperties - Set to True to indicate that document properties should be included, or set to False to indicate that they are omitted.
IgnorePrintAreas - If set to True, ignores any print areas set when publishing. If set to False, uses the print areas set when publishing.
OpenAfterPublish - If set to True, displays the file in the viewer after it is published. If set to False, the file is published but not displayed.
From - The number of the page at which to start publishing. If this argument is omitted, publishing starts at the beginning.
To - The number of the last page to publish. If this argument is omitted, publishing ends with the last page.
FixedFormatExtClassPtr - Pointer to the FixedFormatExt class.
Defining Print Area
The following two lines are equivalent
Activesheet.PageSetup.PrintArea = ""
Activesheet.Names("Print Area").Delete
Activesheet.VPageBreaks(1).Location = Worksheets(1).Range("B5")
Activesheet.VPageBreaks(1).DragOff Direction:=xlDirection.xlToRight RegionIndex:=1
VPageBreaks Collection
A collection of vertical page breaks within the print area.
Each vertical page break is represented by a VPageBreak object
Use the Add method to add a vertical page break.
Activesheet.VPageBreaks.Add Before:=ActiveCell
If you add a page break that does not intersect the print area, then the new VPageBreak object will not appear in the VPageBreaks collection for that sheet.
For an automatic print area, the VPageBreaks property applies only to the page breaks within the print area.
For a user-defined print area of the same range, the VPageBreaks property applies to all the page breaks.
VPageBreaks(1).DragOff (Direction, RegionIndex)
Direction - The direction to drag the page break
RegionIndex - The print area region index for the page break.If the print area is continuous then there is only one print region. If the print area is non continous then there is more than one.
This method drags a page break off the print area.
You have to be in print preview mode for this to work
If you are not in page page preview then an error will be generated.
ActiveWindow.View = xlPageBreakPreview
Activesheet.VPageBreaks(1).DragOff Direction:=xlDirection.xlToRight RegionIndex:=1
ActiveWindow.View = xlNormalView
HPageBreaks Collection
Whenever you use / change the print area of a worksheet by dragging the blue lines in "page break" view, using activesheet.Hpagebreaks(1).dragoff direction, regionindex you will get a Dr Watson if the page breaks to does not exist.
How many pages will be printed ?
To determine the number of pages that will be printed for the active worksheet use:
This is an XLM (Excel 4) macro.
Public Sub ShowPageCount()
Dim ipagecount As Integer
Dim ipages As Integer
Dim objwsh as Worksheet
ipagecount = 0
For Each objwsh In Worksheets
objwsh.Activate
ipages = ExecuteExcel4Macro("Get.Document(50)")
ipagecount = ipagecount + ipages
Next objwsh
End Sub
PageSetup - Page tab
With ActiveSheet.PageSetup
.Orientation = xlPageOrientation.xlLandscape
.Zoom = 100
.FitToPagesWide = 1
.FitToPagesTall = 1
.FitToPagesTall = False ' Automatic
.PaperSize = xlPaperSize.xlPaperA4
.PrintQuality = 300
.FirstPageNumber = Constants.xlAutomatic | 5
End With
PageSetup - Margins tab
Margins are set or returned in Points.
The units that are displayed on the Page Setup dialog box are inches although the units accepted for the following properties are Points.
How can you define 0.5 (or the smallest margins) for all margins ??
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.CenterHorizontally = False
.CenterVertically = False
End With
You can use the following conversion functions to help convert between the various units.
ActiveSheet.PageSetup.LeftMargin = Application.CentimetersToPoints(1.9)
ActiveSheet.PageSetup.LeftMargin = Application.MillimetersToPoints(1.9)
ActiveSheet.PageSetup.LeftMargin = Application.InchesToPoints(1.9)
For more details, please refer to the Measurements page.
PageSetup - Header and Footer tab
This is from the Header/Footer tab of the Page Setup dialog box.
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
End With
In Excel 2002 you can include the full file path in a custom header or footer
ActiveSheet.Pagesetup.CenterFooter = ActiveWorkbook.FullName
Worksheets(1).PageSetup.CenterFooter = ActiveWorkbook.FullName
It is possible to write code to insert a page header in the centre position although the CenterHeader property (as well as the other Header and Footer properties) are not very helpful.
These should be objects but do not appear to be ??
ActiveSheet.PageSetup.CenterHeader = &""Arial,Bold Italic""&11Better Solutions"
PageSetup - Sheet tab
With ActiveSheet.PageSetup
.PrintArea = "$B$2:$D$20"
'defining the print area automatically displays page break lines on the worksheet
'these can be hidden using the following line: ActiveSheet.DisplayAutomaticPageBreaks = False
.PrintTitleRows = "$B$2:$D$20"
.PrintTitleColumns = ""
.PrintGridlines = False
.BlackAndWhite = False
.Draft = False
.PrintHeadings = False
.PrintComments = xlPrintLocation.xlPrintNoComments
.PrintErrors = xlPrintErrors.xlPrintErrorsDisplayed
.Order = xlOrder.xlDownThenOver
End With
Header and Footer
This example prints the workbook name and page number at the bottom of each page.
Worksheets("Sheet1").PageSetup.CenterFooter = "&F page &P"
This example prints the date and page number at the top of each page.
Worksheets("Sheet1").PageSetup.CenterHeader = "&D page &P of &N"
Header and Footer - Graphic Object
Contains properties that apply to header and footer picture objects.
Using the Graphic object
There are several properties of the PageSetup object that return the Graphic object.
Use the CenterFooterPicture, CenterHeaderPicture, LeftFooterPicture, LeftHeaderPicture, RightFooterPicture, or RightHeaderPicture properties to return a Graphic object.
CenterFooterPicture - Returns a Graphic object that represents the picture for the center section of the footer. Used to set attributes about the picture.
The CenterFooterPicture property is read-only, but the properties on it are not all read-only.
The following example adds a picture titled: Sample.jpg from the C:\ drive to the left section of the footer. This example assumes that a file called Sample.jpg exists on the C:\ drive.
Sub InsertPicture()
With ActiveSheet.PageSetup.LeftFooterPicture
.FileName = "C:\Sample.jpg"
.Height = 275.25
.Width = 463.5
.Brightness = 0.36
.ColorType = msoPictureGrayscale
.Contrast = 0.39
.CropBottom = -14.4
.CropLeft = -28.8
.CropRight = -14.4
.CropTop = 21.6
End With
' Enable the image to show up in the left footer.
ActiveSheet.PageSetup.LeftFooter = "&G"
End Sub
Note It is required that "&G" is a part of the LeftFooter string in order for the image to show up in the left footer.
Prevent Users From Printing
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Cancel = True
Call MsgBox("You are not allowed to print this workbook.", vbInformation + vbOKOnly)
End Sub
Prevent Certain Sheets
You could still select a different worksheet and then print the whole workbook ??
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Select Case ActiveSheet.Name
Case "Sheet1", "Sheet2"
Cancel = True
Call MsgBox("You are not allowed to print this particular worksheet.", vbInformation + vbOKOnly)
End Select
End Sub
© 2026 Better Solutions Limited. All Rights Reserved. © 2026 Better Solutions Limited TopPrev