Pictographs using VBA

[bgeniusz]

I am trying to change the columns of a Waterfall chart from bars to an arrow. I know how to accomplish this in Excel but I need to make this happen for the user with VBA. The macro recorder does not work when modifying charts in Excel so I cannot find the code to create a pictograph there or anywhere else online. Any help would be greatly appreciated.

I have also tried to create the arrow and then copy it to the series columns (a procedure that works in Excel but not using VBA).

Is there a way to create a pictograph (column chart using a shape not a rectangle) using VBA?

 

[tlowry]

Here's some VBA to do what I think you want.

• Copy the two subs below into a Module
• Create a bar chart (note the name)
• Create shapes that are to be used (the can be not visible) in the worksheet with the chart (note the name(s))
• Modify the DoSeries chart_name, series_number, shape_name
• Run the test
• Test sub
• Let me know what needs to be changed

Sub test()
    Dim sResult As String
    sResult = [COLOR=green][B]DoSeries[/B][/COLOR]("Chart 11", 1, "BlueArrow")
        If sResult <> "" Then MsgBox sResult
    sResult = DoSeries("Chart 11", 2, "RedArrow")
        If sResult <> "" Then MsgBox sResult
End Sub

Option Explicit
Function DoSeries(sChart, iSeries, sShape) As String
    DoSeries = ""
    On Local Error GoTo errors
    Application.ScreenUpdating = False
    Dim bVis As Boolean: bVis = ActiveSheet.Shapes(sShape).Visible
    ActiveSheet.Shapes(sShape).Visible = True
    Dim ac As Object: Set ac = ActiveCell
    ActiveSheet.Shapes(sShape).Select
    Selection.Copy
    ActiveSheet.ChartObjects(sChart).Activate
    ActiveChart.SeriesCollection(iSeries).Select
    Selection.Paste
    ac.Select
errors:
    If Err <> 0 Then
        DoSeries = Err.Description & String(2, vbCrLf) & _
                   "Chart     " & sChart & vbCrLf & "Series    " & _
                   iSeries & vbCrLf & "Shape    " & sShape
        ac.Select
    End If
    ActiveSheet.Shapes(sShape).Visible = bVis
    Application.ScreenUpdating = True
End Function

 

[bgeniusz]

Yeah! This code worked for solving my problem. Thank you very much. From what was posted, the code errored out with two lines (both in the "doseries" function:

ActiveChart.ChartObjects(sChart).Activate
ac.Select

I simply remarked them out and the code worked to accomplish the task but the message boxes still showed the error of:
"Object variable or With Block variable not set" and the correct names of the chart, series and arrow.

I then took the msgbox out of the code and ran it again. The code worked and replaced all of the columns with my arrows beautifully. Thank you.

Here is what the final code looks like - since I did not need the msgbox, I simply called the "DoSeries" directly.

Private Function DoSeries(sChart, iSeries, sShape) As String
    DoSeries = ""
    On Local Error GoTo errors
    Application.ScreenUpdating = False
    Dim bVis As Boolean: bVis = ActiveChart.Shapes(sShape).Visible
    ActiveChart.Shapes(sShape).Visible = True
    Dim ac As Object: Set ac = ActiveCell
    ActiveChart.Shapes(sShape).Select
    Selection.Copy
    'ActiveChart.ChartObjects(sChart).Activate
    ActiveChart.SeriesCollection(iSeries).Select
    Selection.Paste
    ac.Select
errors:
    If Err <> 0 Then
        DoSeries = Err.Description & String(2, vbCrLf) & _
                   "Chart     " & sChart & vbCrLf & "Series    " & _
                   iSeries & vbCrLf & "Shape    " & sShape
        'ac.Select
    End If
    ActiveChart.Shapes(sShape).Visible = bVis
    Application.ScreenUpdating = True
End Function