Excel VBA guide

Tutotials:

Anthony's VBA page
Excel VBA Tutorial
Control PowerPoint from Excel

Select a range and change the cell values randomly

Sub FloatAround()
Dim selRange As Range
Dim txt As String

If Selection Is Nothing Then GoTo ErrorMsg
If TypeName(Selection) <> "Range" Then GoTo ErrorMsg
If Selection.Areas.Count > 1 Then GoTo ErrorMsg

Set selRange = Selection
selRange.NumberFormat = "0.00"
For i = 1 To selRange.Rows.Count
  For j = 1 To selRange.Rows(i).Cells.Count
      txt = CStr(selRange.Rows(i).Cells(j).Value + (Rnd / 3#))
      selRange.Rows(i).Cells(j).Value = txt
  Next j
Next i

Exit Sub
ErrorMsg:
MsgBox "Incorrect Selection", vbOKOnly + vbCritical
End Sub

Copy several charts from excel into a new power point presentation

Modified from http://www.erlandsendata.no/english/index.php?d=envbaolecontrolpowerpoint

Sub CreateNewPowerPointPresentation()
' to test this code, paste it into an Excel module
' add a reference to the PowerPoint-library
' create a new folder named C:\Foldername or edit the filnames in the code
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim i As Integer, strString As String
Dim fileName As String
Dim chartName As String

   fileName = "C:\Documents and Settings\hzg3nc\Desktop\VBA.ppt"
 
   Set pptApp = CreateObject("PowerPoint.Application")
   Set pptPres = pptApp.Presentations.Add(msoTrue) ' create a new presentation
   ' or open an existing presentation
   ' Set pptPres = pptApp.Presentations.Open("C:\Foldername\Filename.ppt")
 
   ' apply a slide template
   pptPres.ApplyTemplate "C:\Documents and Settings\hzg3nc\Application Data\Microsoft\Templates\default.pot"
 
   ActiveWorkbook.Charts("Chart-Main").ChartArea.Copy ' copy an Excel chart
   With pptPres.Slides
       Set pptSlide = .Add(.count + 1, ppLayoutTitleOnly) ' add a slide
   End With
   With pptSlide
       .Shapes(1).TextFrame.TextRange.Text = ActiveWorkbook.Charts("Chart-Main").ChartTitle.Characters.Text ' add a slide title
       .Shapes(1).TextFrame.TextRange.Font.Size = 22
       .Shapes.PasteSpecial ppPasteBitmap
       With .Shapes(.Shapes.count)
           .Left = 10
           .Top = 70
           .Height = 425
           .Width = 695
       End With
   End With
 
   For i = 1 To 11
       chartName = "Chart " + CStr(i)
       ActiveWorkbook.Charts(chartName).ChartArea.Copy ' copy an Excel chart
       With pptPres.Slides
           Set pptSlide = .Add(.count + 1, ppLayoutTitleOnly) ' add a slide
       End With
       With pptSlide
           .Shapes(1).TextFrame.TextRange.Text = ActiveWorkbook.Charts(chartName).ChartTitle.Characters.Text ' add a slide title
           .Shapes(1).TextFrame.TextRange.Font.Size = 22
           .Shapes.PasteSpecial ppPasteBitmap
           With .Shapes(.Shapes.count)
               .Left = 10
               .Top = 70
               .Height = 425
               .Width = 695
           End With
       End With
   Next i
 
 
   Application.CutCopyMode = False ' end cut/copy from Excel
   Set pptSlide = Nothing
 
   On Error Resume Next ' ignore errors
   Kill fileName
   With pptPres
       .SaveAs fileName
       '.Close ' close the presentation
   End With
   On Error GoTo 0 ' resume normal error handling
   Set pptPres = Nothing
 
   pptApp.Visible = True ' display the application
   'pptApp.Quit ' or close the PowerPoint application
   Set pptApp = Nothing
End Sub

Create bubble charts from excel sheet

Sub CreateBubbleChart()
Dim rMain As Range
Dim strVal As String, sIndex As Integer, lastRow As Integer, firstRow As Integer, count As Integer
Dim sCollection As SeriesCollection

    Sheets("customer_annoyance").Activate
    Range("D2:F7").Select
    Charts.Add
    ActiveChart.ChartType = xlBubble3DEffect

    Set rMain = Sheets("customer_annoyance").Range("A1:F66")

    strVal = rMain.Cells(2, 2)
    sIndex = 2
    count = 1
    Set sCollection = ActiveChart.SeriesCollection
    sCollection.Item(1).Delete
    For i = 3 To rMain.Rows.count
        If rMain.Cells(i, 2) <> strVal Then
           
            'MsgBox strVal & " (" & CStr(sIndex) & " to " & CStr(i - 1) & ")"
            firstRow = sIndex
            lastRow = i - 1
           
           
            sCollection.Add Source:=rMain.Range("D" & CStr(firstRow) & ":F" & CStr(lastRow))
                       
            ActiveChart.SeriesCollection(count).XValues = _
                "=customer_annoyance!R" & CStr(firstRow) & "C4:R" & CStr(lastRow) & "C4"
            ActiveChart.SeriesCollection(count).Values = _
                "=customer_annoyance!R" & CStr(firstRow) & "C5:R" & CStr(lastRow) & "C5"
            ActiveChart.SeriesCollection(count).name = _
                "=customer_annoyance!R" & CStr(firstRow) & "C2"
            ActiveChart.SeriesCollection(count).BubbleSizes = _
                "=customer_annoyance!R" & CStr(firstRow) & "C6:R" & CStr(lastRow) & "C6"
            count = count + 1
            strVal = rMain.Cells(i, 2)
            sIndex = i
        End If
    Next i
    'MsgBox strVal & " (" & CStr(sIndex) & " to " & CStr(i - 1) & ")"
    firstRow = sIndex
    lastRow = i - 1
    ActiveChart.SeriesCollection(count).name = _
        "=customer_annoyance!R" & CStr(firstRow) & "C2"
    ActiveChart.SeriesCollection(count).XValues = _
        "=customer_annoyance!R" & CStr(firstRow) & "C4:R" & CStr(lastRow) & "C4"
    ActiveChart.SeriesCollection(count).Values = _
        "=customer_annoyance!R" & CStr(firstRow) & "C5:R" & CStr(lastRow) & "C5"
    ActiveChart.SeriesCollection(count).BubbleSizes = _
        "=customer_annoyance!R" & CStr(firstRow) & "C6:R" & CStr(lastRow) & "C6"
   
   
    ActiveChart.Location Where:=xlLocationAsNewSheet, name:="Chart-One"
    With ActiveChart
        .HasTitle = True
        .ChartTitle.Characters.Text = _
        "Frequency (IPTV) vs Severity (Customer Impact)"
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = _
        "Severity (Customer Impact)"
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Frequency (IPTV)"
    End With
    ActiveChart.SeriesCollection(1).Select
    With ActiveChart.ChartGroups(1)
        .VaryByCategories = False
        .ShowNegativeBubbles = False
        .SizeRepresents = xlSizeIsArea
        .BubbleScale = 35
    End With
    With ActiveChart.Axes(xlCategory)
        .MinimumScale = 4
        .MaximumScale = 11
    End With
    With ActiveChart.Axes(xlValue)
        .MinimumScale = 0
        .MaximumScale = 25
    End With

End Sub

Create individual series charts from a master bubble chart

Sub CopyCharts()
Dim src As Chart
Dim des As Chart
Dim index As Integer
Dim name As String
Dim series As series
Dim sCollection As SeriesCollection
Dim lEntries As LegendEntries
Dim l As LegendEntry

    Set src = Sheets("Chart-One")
   
    For index = 1 To 11
        src.Copy Before:=Sheets("customer_annoyance")
        Set des = ActiveChart
        name = "Dhart " & CStr(index)
        des.name = name
       
        Set sCollection = des.SeriesCollection
        Set lEntries = des.legend.LegendEntries
       
        For i = 1 To sCollection.count
            Set series = sCollection.Item(i)
            If (i <> index) Then
                series.Border.LineStyle = xlNone
                series.Interior.ColorIndex = xlNone
                               
                Set l = lEntries.Item(i)
                l.Font.ColorIndex = 2
                l.Font.Background = xlTransparent
            Else
            End If
        Next i
    Next index
End Sub