将图表模板嵌入宏

时间:2017-12-27 01:20:44

标签: excel vba excel-vba charts

我正在尝试将图表模板应用到宏中并需要帮助。 我有用于创建散点图的宏的代码:

    byte[] image = mImage.retreiveImageFromDB();
    Bitmap bitmap = BitmapFactory.decodeByteArray(image, 0, image.length);
    profileImage.setImageBitmap(bitmap);

并希望将以下代码嵌入到上面的代码中,以便在我运行此宏时将模板应用于我创建的图表。我最初的猜测是将它置于“Private Sub BuildCharts”之下。我怎么能这样做?谢谢。

Option Explicit

Public Sub Test()

' Keyboard Shortcut: Ctrl+Shift+X

Dim wb As Workbook
Dim ws As Worksheet

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1") 'change as appropriate

Application.ScreenUpdating = False

BuildChart ws, SelectRanges(ws)

Application.ScreenUpdating = True

End Sub

 Private Function SelectRanges(ByRef ws As Worksheet) As Range

 Dim rngX As Range
 Dim rngY As Range

 ws.Activate

 Application.DisplayAlerts = False

 On Error Resume Next

 Set rngX = Application.InputBox("Please select X values. One column.", 
 Type:=8)

 If rngX Is Nothing Then GoTo InvalidSelection

 Set rngY = Application.InputBox("Please select Y values. One column.", 
 Type:=8)

 If rngY Is Nothing Then GoTo InvalidSelection

 If rngX.Columns.Count > 1 Or rngY.Columns.Count > 1 Then GoTo 
 InvalidSelection

 On Error GoTo 0

 Set SelectRanges = Union(rngX, rngY)
 Application.DisplayAlerts = True
 Exit Function

 InvalidSelection:
If rngX Is Nothing Or rngY Is Nothing Then
    MsgBox "Please ensure you have selected both X and Y ranges."
ElseIf rngX.Rows.Count <> rngX.Rows.Count Then
     MsgBox "Please ensure the same number of rows are selected for X and Y 
ranges"
ElseIf rngX.Columns.Count > 1 Or rngY.Columns.Count > 1 Then
    MsgBox "Please ensure X range has only one column and Y range has only 
one column"
Else
   MsgBox "Unspecified"
End If

Application.DisplayAlerts = True
End

End Function

Private Sub BuildChart(ByRef ws As Worksheet, ByRef unionRng As Range)

 With ws.Shapes.AddChart2(240, xlXYScatter).Chart
    .SetSourceData Source:=unionRng
End With

ActiveChart.ApplyChartTemplate ( _
    "C:\Users\maaro\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")

End Sub

1 个答案:

答案 0 :(得分:0)

也许可以像这样修改Sub BuildChart

Private Sub BuildChart(ByRef ws As Worksheet, ByRef unionRng As Range)

    With ws.Shapes.AddChart2(240, xlXYScatter).Chart
        .SetSourceData Source:=unionRng
        .ApplyChartTemplate ( _
            "C:\Users\maaro\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
    End With

End Sub