Simple Microsoft VBA Macros for Excel, PowerPoint, & Word

[Charts] How to Display Totals on a Stacked Column (Bar) Chart

2009-12-04T17:59:00.000-08:00

Lets say, there is a stacked column chart in Excel created using the data as shown:

Now, we want to display totals, for example 34 + 43 = 77 at the top of the stacked columns. In stacked column chart, Excel does not allow the "Outer End" option of Data Label position.

To overcome this limitation, create a "Total" column in the data table as shown:

Now change the source data of the chart to include column D as shown below:

The Total column will appear as show above.
Next, right-click on the new "total" series and change the Chart Type to Line and the resulting chart is shown below:

Next, double-click on the Line and set the Line color as "None" and Marker as "None" under the "Patterns" tab.
Go to "Data Labels" tab and select "Value" checkbox, and the resulting final chart will look like this:

Hope you found this tutorial helpful.

[Excel] Creating a Custom Menu/Command bar Using VBA Macro and Add-Ins

2009-12-01T20:11:00.000-08:00

This macro creates a custom command bar at the bottom part of the Excel window as shown.

The command bar has three menu items. Each of the menu items are assigned to a macro.
Here is how to go about creating a custom command bar:

Step 1: Create a new Excel file and use the code below to create your own command bar
Step 2: Save the file as an AddIn, for example "Utility.xla".
Step 3: Go to Tools -> Add-ins and browse the addin file you created as shown. Each time Excel is opened, this add-in is called and the Command Bar is ready to use.

'=========================================================================
' Creating Utility Command Bar with Button Menu Items with Icons

' Copyright vbacentral.blogspot.com
'=========================================================================
Option Explicit
Sub Create_Utility_Menu()
Dim MyBar As CommandBar
Dim MyPopup As CommandBarPopup
Dim MyButton As CommandBarButton
' Delete Menu, if it was already created

On Error Resume Next
CommandBars("Utility Menu").Delete
On Error GoTo 0
' Create a Command Bar object on the bottom of the Excel window

Set MyBar = CommandBars.Add(Name:"Utility Menu", _
    Position:=msoBarBottom, Temporary:=True)
With MyBar
    '.Width = 200
    .Visible = True
    Set MyButton = MyBar.Controls.Add(Type:=msoControlButton)
    With MyButton
        .Caption = "Move Sheets Around"
        .Style = msoButtonIconAndCaption
        'Other Menu item types include:
        'msoButtonAutomatic, msoButtonIcon, msoButtonCaption, or msoButtonIconandCaption
        .BeginGroup = True
        'Assign a macro (in this case macro name is MoveSheets)
        .OnAction = "MoveSheets"
        'Assign a picture icon using predefined Office icons
        .FaceId = 1771
    End With
    Set MyButton = MyBar.Controls.Add(Type:=msoControlButton)
    With MyButton
        .Caption = "Hide/Unhide Sheets"
        .Style = msoButtonIconAndCaption
        .BeginGroup = True
        'Assign a macro (in this case macro name is HideUnhideSelectedSheets)
        .OnAction = "HideUnhideSelectedSheets"
        'Assign a picture icon using predefined Office icons
        .FaceId = 488
    End With
    Set MyButton = MyBar.Controls.Add(Type:=msoControlButton)
    With MyButton
        .Caption = "Go to Sheet"
        .Style = msoButtonIconAndCaption
        .BeginGroup = True
        'Assign a macro (in this case macro name is GoToSheet)
        .OnAction = "GoToSheet"
        'Assign a picture icon using predefined Office icons
        .FaceId = 917
    End With
End With
End Sub

[Excel] Making Chart Series Invisible

2009-11-25T15:33:00.001-08:00

'-----------------------------------------------------------------

'Make a Chart Series Invisible 
'----------------------------------------------------------------- 
'This macro loops through all he series of a selected chart 
'and for each series in the chart, it asks the user if they want 
'to make the series invisible 
'Making a series invisible simply means the following: 
'-Setting the Border as None 
'-Setting the Background Color as None 
'-Setting the Marker Type as None 
'For this macro to work properly, a chart has to be selected 
'Copyright: vbacentral.blogspot.com 
'----------------------------------------------------------------- 

Sub MakeSeriesInvisible()
  Dim s As Series
    For Each s In ActiveChart.SeriesCollection
      With s
        resp = MsgBox("Do you want to make series: " & Chr(34) & _
                       s.Name & Chr(34) & " invisible?", vbYesNo)
        If resp = vbYes Then 
          .Border.LineStyle = xlNone
          .MarkerBackgroundColorIndex = xlColorIndexNone
          .MarkerStyle = xlNone
        End If 
      End With 
    Next s
End Sub

[Excel] Changing Chart Series Order

2009-11-25T14:43:00.000-08:00

Here is a Bar Chart with Series 1 to 6. (bottom-up)

The data table is as shown below

If the series order required is: 5, 1, 3, 2, 6, 4 then enter the series names inside the code and select the chart and run the macro. The series order will be changed accordingly.

'--------------------------------------------------------------- 
'This macro changes the order of series in a collection of series 
'of a chart. The series names has to be hard coded inside this 
'code. 
'For this macro to work property 
'1. A chart should be selected 
'2. It should have more than 1 series 
'Copyright vbacentral.blogspot.com 
'--------------------------------------------------------------- 

Sub OrderFeesSeriesOfActiveChart()
 
  Dim sc As SeriesCollection
  Dim s As Series
  Dim LookupArray(6, 2) As Variant 
  Dim SeriesNameArray() As Variant 
  Dim OrderArray() As Variant 
  Dim Temp(1, 2) As Variant 
  Dim str, str1 As String 
  Dim SeriesCount, Count As Integer 
 
  Set sc = ActiveChart.SeriesCollection
  
  ' Count the number of series in the selected chart 
  Count = 0
  For Each s In sc
    If Trim(s.Name) <> "Total" Then Count = Count + 1
  Next s
  
  SeriesCount = Count
  
  ReDim SeriesNameArray(SeriesCount)
  ReDim OrderArray(SeriesCount, 2)
  
  ' Create 2x2 Lookup array with order wanted. 
  ' Hardcode the series names according to the desired order
  LookupArray(1, 1) = "Series 5"
  LookupArray(2, 1) = "Series 1"
  LookupArray(3, 1) = "Series 3"
  LookupArray(4, 1) = "Series 2"
  LookupArray(5, 1) = "Series 6"
  LookupArray(6, 1) = "Series 4"
  LookupArray(1, 2) = 1
  LookupArray(2, 2) = 2
  LookupArray(3, 2) = 3
  LookupArray(4, 2) = 4
  LookupArray(5, 2) = 5
  LookupArray(6, 2) = 6
 
   'Store series names in an array 
    For k = 1 To UBound(SeriesNameArray())
      SeriesNameArray(k) = Trim(sc(k).Name)
    Next k
    
   'Lookup series order from Lookup array 
    For i = 1 To UBound(LookupArray())
        For j = 1 To UBound(SeriesNameArray())
          If LookupArray(i, 1) = SeriesNameArray(j) Then 
            OrderArray(j, 1) = LookupArray(i, 1)
            OrderArray(j, 2) = LookupArray(i, 2)
            End If 
        Next j
    Next i
    
   'Sort the elements in OrderArray using order obtained from Lookup array 
    For i = 1 To SeriesCount - 1
      For j = i + 1 To SeriesCount
        If OrderArray(i, 2) > OrderArray(j, 2) Then 
          Temp(1, 1) = OrderArray(j, 1)
          Temp(1, 2) = OrderArray(j, 2)
          OrderArray(j, 1) = OrderArray(i, 1)
          OrderArray(j, 2) = OrderArray(i, 2)
          OrderArray(i, 1) = Temp(1, 1)
          OrderArray(i, 2) = Temp(1, 2)
        End If 
      Next j
    Next i
  'Assign new series order 
 
  For Each s In sc
      For i = 1 To SeriesCount
          If Trim(s.Name) = OrderArray(i, 1) Then 
              s.PlotOrder = i
          End If 
      Next i
  Next s
 
End Sub

[Excel] Hiding/Unhiding sheets using an User Form

2009-11-20T14:37:00.000-08:00

'************************************************************
' The code to call the Form should be written in Modules Section
'************************************************************
Sub HideUnhideSelectedSheets()
UserFormHideUnhide.Show
End Sub

' The Code to generate form should be written inside Forms section as shown below:
' Create a Form named "UserFormHideUnhide"

'************************************************************
'*** Code behind UserFormHideUnhide form
' - The form displays Visible and Invisible sheets
' side-by-side. The users can use the buttons to switch
' sheets between Hidden and Visible options
' - Once the user submits the form all the changes are
' applied to the sheets' visibility
'*** Names of the Controls on the UserForm
' Listbox: ListBox1 - displays a list of visible sheets
' Listbox: ListBox2 - displays a list of hidden sheets
' Button: MoveAllToRight - ">>" used to make all sheets
' but one hidden
' Button: MoveSelectedToRight - ">" hide one sheet at a time
' Button: MoveSelectedToLeft - "<" unhide one sheet at a time ' Button: MoveAllToLeft - ">>" used to make all sheets
' visible
' Button: Cancel - used to cancel the Form(dialog box)
' Button: Hide/Unhide - used to submit the UserForm
'************************************************************

'*** Initialize dialog box with Visible and Hidden sheets list

Private Sub UserForm_Initialize()

Dim sht As Variant
Dim shts As Sheets

For Each sht In ActiveWorkbook.Sheets
If sht.Visible Then
ListBox1.AddItem sht.Name
Else: ListBox2.AddItem sht.Name
End If
Next sht

End Sub

'*** Button to Hide all Visible sheets
Private Sub MoveAllToRight_Click()
'Add all but one Visible sheets into Hidden sheets list
For i = 1 To ListBox1.ListCount - 1
ListBox2.AddItem ListBox1.List(i)
Next i
'Remove all but one sheets from Visible sheets list
For i = 1 To ListBox1.ListCount - 1
ListBox1.RemoveItem (1)
Next i

MsgBox "At least one sheet should be visible"

End Sub

'***Button to hide selected visible sheets
Private Sub MoveSelectedToRight_Click()

Dim CountVisibleSheets, LastSelection, j As Integer
CountVisibleSheets = ListBox1.ListCount - 1

'Excel requires at least one sheet to be visible
If ListBox1.ListCount = 1 Then
LastSelection = 0
MsgBox "At least one sheet should be visible"
Else
'Add selected sheets to Hidden sheets listbox
For i = 0 To CountVisibleSheets
If ListBox1.Selected(i) Then
ListBox2.AddItem ListBox1.List(i)
End If
Next i

'Remove selected sheets from Visible sheets list
j = 0
Do Until j = ListBox1.ListCount
If ListBox1.Selected(j) Then
ListBox1.RemoveItem (j)
LastSelection = j
j = j - 1
End If
j = j + 1
Loop
End If

'Maintain a selection by moving selection to next visible sheet
If LastSelection < ListBox1.ListCount Then
ListBox1.Selected(LastSelection) = True
Else
ListBox1.Selected(LastSelection - 1) = True
End If

End Sub

'*** Button to Unhide selected Hidden sheets
Private Sub MoveSelectedToLeft_Click()
Dim CountVisibleSheets, LastSelection As Integer
CountVisibleSheets = ListBox2.ListCount - 1

For i = 0 To CountVisibleSheets
If ListBox2.Selected(i) Then
ListBox1.AddItem ListBox2.List(i)
End If
Next i

j = 0
Do Until j = ListBox2.ListCount
If ListBox2.Selected(j) Then
ListBox2.RemoveItem (j)
LastSelection = j
j = j - 1
End If
j = j + 1
Loop
'Maintain a selection by moving selection to next Hidden sheet
If LastSelection < ListBox2.ListCount Then
ListBox2.Selected(LastSelection) = True
ElseIf ListBox2.ListCount = 0 Then
Else
ListBox2.Selected(LastSelection - 1) = True
End If
End Sub

'*** Button to Unhide all Hidden sheets
Private Sub MoveAllToLeft_Click()
Dim CountHiddenSheets As Integer
CountHiddenSheets = ListBox2.ListCount - 1

For i = 0 To CountHiddenSheets
ListBox1.AddItem ListBox2.List(i)
Next i

For i = 0 To CountHiddenSheets
ListBox2.RemoveItem (0)
Next i
End Sub

'*** Cancel dialog button
Private Sub CommandCancel_Click()
Unload UserFormHideUnhide
End Sub

'*** Submit selection for hiding and unhiding sheets
Private Sub CommandHideUnhide_Click()
For i = 0 To ListBox1.ListCount - 1
ActiveWorkbook.Sheets(ListBox1.List(i)).Visible = True
Next i
For i = 0 To ListBox2.ListCount - 1
If i = ActiveWorkbook.Sheets.Count - 1 Then
MsgBox "At least one sheet should be visible"
Exit For
Else
ActiveWorkbook.Sheets(ListBox2.List(i)).Visible = False
End If
Next i
End Sub

Excel: Hide Unhide Comments

2009-11-19T16:12:00.001-08:00

'-----------------------------------------------------------------
' Hide/Unhide Comments
' This macro toggles comments display
'-----------------------------------------------------------------
Sub ShowComments()

Application.DisplayCommentIndicator = Application.DisplayCommentIndicator * -1

End Sub

Excel: Toggle Hide Unhide data sheets

2009-11-19T16:04:00.001-08:00

'--------------------------------------------------------------------------------
' Toggle Hide Unhide data sheets
' This macro creates an array of sheet names and upon running this macro
' will hide/unhide sheets
' Note: Atleast one sheet should be visible
'
'--------------------------------------------------------------------------------
Sub ToggleHideUnhideDataSheets()

Application.ScreenUpdating = False

Dim wb As Workbook
Dim ShtNames() As Variant

Set wb = ActiveWorkbook

ShtNames = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")

For i = 0 To UBound(ShtNames)
wb.Sheets(ShtNames(i)).Visible = Not wb.Sheets(ShtNames(i)).Visible
Next i

End Sub

Excel Charts: Change Chart Series Type from Bar to Line

2009-11-19T15:59:00.000-08:00

'--------------------------------------------------------------------------
' Macro to change Chart Series type to Line
' For this macro to work properly a bar chart has to be selected
'--------------------------------------------------------------------------
Sub ChangeSeriesType_Bar_to_Line()
Dim s As Series
For Each s In ActiveChart.SeriesCollection
With s
resp = MsgBox("Do you want to change series: " & Chr(34) & _
s.Name & Chr(34) & " type from Bar to Line?", vbYesNo)
If resp = vbYes Then
.ChartType = xlLineMarkers
End If
End With
Next s
End Sub

Excel: Copy Range/Chart to PowerPoint

2009-11-19T15:25:00.000-08:00

'**************************************************************************
' Copy Excel Range/Chart to PowerPoint
' This macro copies a range/chart from Excel to PowerPoint.
' 1. PowerPoint presentation should be opened for the macro to work properly
' 2. Macro asks for user input whether to copy a range or chart
' 3. Then asks whether to paste as Link as picture or link
' 4. It also makes sure the chart/range fits into PowerPoint slide by adjusting
' the height and width of pasted object.
'**************************************************************************
Sub Copy_Paste_to_PowerPoint()
'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE
Dim ppApp As PowerPoint.Application
Dim ppSlide As PowerPoint.Slide

Dim msg As String
Dim temp As Variant

Dim PasteChart As Boolean
Dim PasteChartLink As Boolean

Dim lHeight As Long
Dim lWidth As Long

'Look for existing instance of PowerPoint
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0

'Sets current slide to active slide
Set ppSlide = ppApp.ActiveWindow.View.Slide

'Copy Range/Chart?
temp = MsgBox("Do you want to Copy-Paste Chart or Range? Yes=Chart ; No=Range", vbYesNo)
If temp = 6 Then
PasteChart = True
Else
PasteChart = False
End If

'Pasting a Chart
If PasteChart = True Then
Select Case TypeName(Selection)
'Paste Chart/Charts
Case "Chart", "ChartArea"
'Paste Chart as picture/link?
temp = MsgBox("Paste chart as a picture? Yes=Picture ; No=Link", vbYesNo)
If temp = 7 Then
PasteChartLink = True
Else
PasteChartLink = False
End If
'Copy Paste action
If PasteChartLink = True Then
'Copy & Paste Chart Linked
'ActiveChart.ChartArea.Copy
Selection.Copy
ppSlide.Shapes.PasteSpecial(link:=True).Select
Else
'Copy & Paste Chart Not Linked
'ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
'ppSlide.Shapes.Paste.Select
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select
End If
'Paste DrawingObjects (Multiple charts/drawing objects)
Case "DrawingObjects"
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select
Case Else
msg = MsgBox("Select a Chart and run macro", vbOKOnly, "Select a Chart")
'End Sub
End Select
'Pasting a Range
Else
'Paste Chart as picture/link?
temp = MsgBox("Paste Range as a picture? Yes=Picture ; No=Link", vbYesNo)
If temp = 7 Then
PasteRangeLink = False
Else
PasteRangeLink = True
End If
'Options for Copy & Paste Ranges
If RangePasteType = True Then
'Paste Range as Picture
'Worksheets(SheetName).Range(RangeName).Copy
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
Else
'Paste Range as Picture Link
'Worksheets(SheetName).Range(RangeName).Copy
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteMetafilePicture, link:=msoTrue).Select
End If
End If

' Get the slide height and width.
lHeight = ppApp.ActivePresentation.PageSetup.SlideHeight
lWidth = ppApp.ActivePresentation.PageSetup.SlideWidth

' Set Height & Width of pasted object to fit the slide
If ppApp.ActiveWindow.Selection.ShapeRange.Height > lHeight Then
ppApp.ActiveWindow.Selection.ShapeRange.Height = lHeight
End If
If ppApp.ActiveWindow.Selection.ShapeRange.Width > lWidth Then
ppApp.ActiveWindow.Selection.ShapeRange.Width = lWidth
End If

' Center pasted object in the slide
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

' Activate PowerPoint window
AppActivate ("Microsoft PowerPoint")
Set ppSlide = Nothing
Set ppApp = Nothing

End Sub

PowerPoint: Changing Layout of all slides

2009-11-18T21:15:00.000-08:00

'*************************************************************
' Changing Slide Layout
' This macro changes the layout of slides in the range stated
' by counter.
' For a list of Layout types (enumerations) check out the
' Enumerations topic
'*************************************************************

Sub ChangeSlideLayout()

For i = 1 To ActivePresentation.Slides.Count
ActivePresentation.Slides(i).Layout = ppLayoutTitleOnly

Next i

End Sub

PowerPoint: Resizing all the Shapes of a particular shape type

2009-11-18T21:14:00.000-08:00

'*************************************************************
' Resizing all the Shapes of a particular shape type.
' This example sets the height and width of all charts which
' were pasted from Excel into PowerPoint as Linked charts
' This example can be used to format other shape types by
' changing the msoShapeType enumeration.
' For a list of Shape types (enumerations) check out the
' Enumerations topic
'*************************************************************

Sub SetLinkedChartSize()
Dim s As Slide
Dim shp As Shape

For Each s In ActivePresentation.Slides
For Each shp In s.Shapes
If shp.Type = msoLinkedOLEObject Then
With shp
.LockAspectRatio = msoFalse
.Height = 255
.Width = 400
End With
End If
Next shp
Next s

End Sub

PowerPoint: Formating Slide Titles on all slides

2009-11-18T21:12:00.000-08:00

'*************************************************************
' Formating Slide Titles on all slides
' This macro formats the position, Font name and Font size of
' titles on all slides of active presentation
'*************************************************************
Sub FormatSlideTitles()
Dim s As Slide
Dim shp As Shape

For Each s In ActivePresentation.Slides
For Each shp In s.Shapes
If shp.Type = msoPlaceholder Then
With shp
.Top = 5
.TextFrame.TextRange.Font.Name = "Times New Roman"
.TextFrame.TextRange.Font.Size = 24
End With
End If
Next shp
Next s

End Sub

PowerPoint: Update Links to Excel charts and ranges

2009-11-18T21:07:00.000-08:00

'*************************************************************
'Updating all links of OLE objects embedded in PowerPoint
'This macro is intended to Update charts/Ranges that are
'copy-pasted from Excel into PowerPoint using "Paste Link"
[option of Paste Special menu item
'The macro updates all links in the PowerPoint
'*************************************************************
Sub Update_Links()
Dim osld As Slide
Dim oshp As Shape
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.Type = msoLinkedOLEObject Then oshp.LinkFormat.Update
Next oshp
Next osld
End Sub

PowerPoint: Resizing Height and Width of selected shapes

2009-11-18T20:51:00.000-08:00

'**************************************************************
' Setting the size (Width x Height) of selected shapes with user
' input
' For this macro to work properly, you need to select one or
' more shapes.
' The macro asks for user input to enter Width and Height
' By default, the Input box displays maximum height and width
' of all the selected shapes
'**************************************************************
Sub Resize_Selected_Shapes()

Dim shp As Shape
Dim BoxWidth, BoxHeight As Integer

If ActiveWindow.Selection.Type = ppSelectionNone Then
MsgBox "Please select objects to resize", vbExclamation, "Make Selection"
Else
' 1st Pass - get the desired width & height
For Each shp In ActiveWindow.Selection.ShapeRange
If shp.Width > MaxWidth Then MaxWidth = shp.Width
If shp.Height > MaxHeight Then MaxHeight = shp.Height
Next shp

'Get the desired box dimensions - set default as max width & max height
BoxWidth = InputBox("Enter the required Width " & Chr(10) & _
"(Default is Largest Width of selected boxes)", "Box Width", MaxWidth)
BoxHeight = InputBox("Enter the required Height " & Chr(10) & _
"(Default is Largest Width of selected boxes)", "Box Height", MaxHeight)

' 2nd pass - change the sizes
For Each shp In ActiveWindow.Selection.ShapeRange
shp.LockAspectRatio = msoFalse
shp.Width = BoxWidth
shp.Height = BoxHeight
Next shp
End If

End Sub

Word: Copying a Range of Cells from Excel into Word

2009-11-16T18:57:00.000-08:00

'----------------------------------------------------------------------
' Copying a Range of Cells from Excel into Word
'----------------------------------------------------------------------
Sub CopyXLRangeIntoWord()

Dim strData As String
Dim lngChannel As Long
Dim r As Range
Dim str As String
Dim strFilePath As String
Dim strFileName As String

str = "R1C1: R21C7" 'Specify the Excel range you want to copy
strFilePath = "C:\temp\test.xls"
strFileName = "test.xls"

'Open a dynamic data exchange (DDE) channel to Excel Application
lngChannel = DDEInitiate(App:="Excel", Topic:="System")

'Send OPEN command to Excel through initiated channel
DDEExecute Channel:=lngChannel, Command:="[OPEN(" & Chr(34) _
& strFilePath & Chr(34) & ")]"

'Send COPY command to Excel through initiated channel
DDEExecute Channel:=lngChannel, Command:="[COPY(" & Chr(34) _
& "R1C1:R21C7" & Chr(34) & ")]"

'Close the DDE channel to Excel
DDETerminate Channel:=lngChannel

lngChannel = DDEInitiate(App:="Excel", Topic:=strFileName)

'Request information from Excel
strData = DDERequest(Channel:=lngChannel, Item:=str)
'Terminate all channels to Excel
DDETerminateAll

'Paste Excel range into Word Document
'To Paste as text in the beginning of Word document:
ActiveDocument.Range.InsertBefore strData
' To Paste as Picture in the beginning of Word Document:
'ActiveDocument.Range(End:=0).PasteSpecial DataType:=wdPasteEnhancedMetafile

End Sub