Создание графика в Excel VBA

Что делает код: у меня есть код, который читает определенные таблицы и использует данные для создания графика.

Что я делал раньше: Ранее я определял диапазон для этого графа, используя плавающие методы (такие как used range и lastcell). Поскольку при удалении одной строки данных возникла проблема (см. Динамическая ссылка на UsedRange в VBA), я изменил метод ссылки, чтобы учесть количество непустых заголовков столбцов.

Проблема: хотя код кажется работоспособным для первого созданного графа, для других графиков (и до того, как он попадет во второй столбец данных) он выдает ошибку (метод "основная единица" оси объекта не выполнен) в строке указано ниже.

Что ожидалось сделать: до того, как я изменил эталонную процедуру для диапазона, у меня не было этих проблем, и графики строились должным образом.

Вопрос: Есть идеи, что может быть причиной этого?

Obs1: Как предложено в моем предыдущем вопросе, я попытался создать эти графики с использованием таблиц, но пока не смог сделать это должным образом.

Код:

Function Grapher(ChartSheetName As String, SourceWorksheet As String, ChartTitle As String, secAxisTitle As String)

Dim lColumn As Long, lRow As Long
Dim LastColumn As Long, LastRow As Long
Dim RetChart As Chart
Dim w As Workbook
Dim RetRange As Range
Dim chrt As Chart
Dim p As Integer
Dim x As Long, y As Long
Dim numMonth As Long
Dim d1 As Date, d2 As Date
Dim i As Long, j As Long
Dim pt As PivotTable

Set w = ThisWorkbook

j = 2
Do While w.Worksheets(SourceWorksheet).Cells(1, j).Text <> ""
    j = j + 1
Loop

'find limit
LastColumn = j 'w.Sheets(SourceWorksheet).Cells(1, w.Sheets(SourceWorksheet).Columns.Count).End(xlToLeft).column
LastRow = w.Sheets(SourceWorksheet).Cells(w.Sheets(SourceWorksheet).Rows.Count, "A").End(xlUp).Row

'check for sources that do not have full data
'sets the range
i = 3
If SourceWorksheet = "Ret" Or SourceWorksheet = "Vol" Then
    Do While w.Worksheets(SourceWorksheet).Cells(i, 2).Text = "N/A"
        i = i + 1
    Loop

    'pt = w.Sheets(SourceWorksheet).ListObjects.Add(xlSrcRange, Range(w.Worksheets(SourceWorksheet).Cells(i, 1), w.Worksheets(SourceWorksheet).Cells.SpecialCells(xlLastCell)), , xlYes).Name
    'Set RetRange = pt.DataBodyRange
    Set RetRange = w.Worksheets(SourceWorksheet).Range(w.Worksheets(SourceWorksheet).Cells(i, 1), w.Worksheets(SourceWorksheet).Cells(i, LastColumn))
    'Set RetRange = w.Worksheets(SourceWorksheet).Range(w.Worksheets(SourceWorksheet).Cells(i, 1), w.Worksheets(SourceWorksheet).Cells.SpecialCells(xlLastCell))
 Else
    Set RetRange = w.Sheets(SourceWorksheet).Range(w.Worksheets(SourceWorksheet).Cells(1, 1), w.Worksheets(SourceWorksheet).Cells(LastRow, LastColumn))
    'Set RetRange = w.Sheets(SourceWorksheet).UsedRange
    'Set RetRange = w.Sheets(SourceWorksheet).Range("A1:" & Col_Letter(LastColumn) & LastRow)
End If

'''''''''''''''''''''''
For Each chrt In w.Charts
    If chrt.Name = ChartSheetName Then
        Set RetChart = chrt
        RetChart.Activate
        p = 1
    End If
Next chrt

If p <> 1 Then
    Set RetChart = Charts.Add
End If

'count the number of months in the time series, do the ratio
d1 = w.Sheets(SourceWorksheet).Range("A2").Value
d2 = w.Sheets(SourceWorksheet).Range("A" & LastRow).Value

numMonth = TestDates(d1, d2)
x = Round((numMonth / 15), 1)

'ratio to account for period size
If x < 3 Then
    y = 1
ElseIf x >= 3 And x < 7 Then
    y = 4
ElseIf x > 7 Then
    y = 6
End If

'create chart
With RetChart
    .Select
    .ChartType = xlLine
    .HasTitle = True
    .ChartTitle.Text = ChartTitle
    .SetSourceData Source:=RetRange 'change this to be the table
    .Axes(xlValue).MaximumScaleIsAuto = True
    .Axes(xlCategory, xlPrimary).HasTitle = True
    .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Date"
    .Axes(xlValue, xlPrimary).HasTitle = True
    .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = secAxisTitle
    .Name = ChartSheetName
    .SetElement (msoElementLegendBottom)
    .Axes(xlCategory).TickLabelPosition = xlLow
    .Axes(xlCategory).MajorUnit = y '************THIS IS GIVING THE CURRENT ERROR
    .Axes(xlCategory).MajorUnitScale = xlMonths

'sets header names for modified sources
    If SourceWorksheet = "Drawdown" Then
        For lColumn = 2 To LastColumn
            .FullSeriesCollection(lColumn - 1).Name = "=DD!$" & Col_Letter(lColumn) & "$1"
            .FullSeriesCollection(lColumn - 1).Values = "=DD!$" & Col_Letter(lColumn) & "$3:$" & Col_Letter(lColumn) & "$" & LastRow
        Next lColumn
    ElseIf SourceWorksheet = "Ret" Then
        For lColumn = 2 To LastColumn
            If w.Sheets("Ret").Cells(1, lColumn).Value <> "" Then
                .FullSeriesCollection(lColumn - 1).Name = "='Ret'!$" & Col_Letter(lColumn) & "$1"
            Else
                .FullSeriesCollection(lColumn - 1).Name = ""
            End If
        Next lColumn
    ElseIf SourceWorksheet = "Vol" Then
        For lColumn = 2 To LastColumn
            If w.Sheets("Vol").Cells(1, lColumn).Value <> "" Then
                .FullSeriesCollection(lColumn - 1).Name = "='Vol'!$" & Col_Letter(lColumn) & "$1"
            Else
                .FullSeriesCollection(lColumn - 1).Name = ""
            End If
        Next lColumn
    End If
End With

'deleting the extra empty series
Dim nS As Series
'this has to be fixed. For a permanent solution, try to use tables
For Each nS In RetChart.SeriesCollection
    If nS.Name = "Series2" Or nS.Name = "Series3" Or nS.Name = "Series4" Or nS.Name = "Series5" Or nS.Name = "" Then
        nS.Delete
    End If
Next nS

End Function

Function TestDates(pDate1 As Date, pDate2 As Date) As Long

    TestDates = DateDiff("m", pDate1, pDate2)

End Function

Function Col_Letter(lngCol As Long) As String

    Dim vArr
    vArr = Split(Worksheets("TIME SERIES").Cells(1, lngCol).Address(True, False), "$")
    Col_Letter = vArr(0)

End Function
Источник

1 ответ

Решение

Попробуйте приведенный ниже код, я его немного "уберу" и посмотрим, разрешит ли он вашу ошибку при установке Axes(xlCategory).MajorUnit,

Примечание: нет необходимости Select график, чтобы изменить его.

Function Grapher(ChartSheetName As String, SourceWorksheet As String, ChartTitle As String, secAxisTitle As String)

Dim lColumn As Long, lRow As Long
Dim LastColumn As Long, LastRow As Long
Dim RetChart As Chart
Dim w As Workbook
Dim ws As Worksheet
Dim RetRange As Range
Dim chrt As Chart
Dim p As Integer
Dim x As Long, y As Long
Dim numMonth As Long
Dim d1 As Date, d2 As Date
Dim i As Long, j As Long
Dim pt As PivotTable

Set w = ThisWorkbook
Set ws = w.Worksheets(SourceWorksheet)

With ws
    LastColumn = .Range("B1").End(xlToRight).Column ' find last column
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' find last row

    ' check for sources that do not have full data
    ' sets the range
    i = 3
    If SourceWorksheet = "Ret" Or SourceWorksheet = "Vol" Then
        Do While .Range("B" & i).Text = "N/A"
            i = i + 1
        Loop

        'Set RetRange = pt.DataBodyRange
        Set RetRange = .Range(.Cells(i, 1), .Cells(i, LastColumn))
        'Set RetRange = w.Worksheets(SourceWorksheet).Range(w.Worksheets(SourceWorksheet).Cells(i, 1), w.Worksheets(SourceWorksheet).Cells.SpecialCells(xlLastCell))
     Else
        Set RetRange = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
        'Set RetRange = w.Sheets(SourceWorksheet).Range("A1:" & Col_Letter(LastColumn) & LastRow)
    End If
End With

' =====================================
For Each chrt In w.Charts
    If chrt.Name = ChartSheetName Then
        Set RetChart = chrt
       ' RetChart.Activate
    End If
Next chrt

If RetChart Is Nothing Then Charts.Add '<-- no chart found in previous loop

'count the number of months in the time series, do the ratio
d1 = ws.Range("A2").Value
d2 = ws.Range("A" & LastRow).Value

numMonth = DateDiff("m", d1, d2)
x = Round((numMonth / 15), 1)

'ratio to account for period size
If x < 3 Then
    y = 1
ElseIf x >= 3 And x < 7 Then
    y = 4
ElseIf x > 7 Then
    y = 6
End If

' create chart
With RetChart
  '  .Select
    .ChartType = xlLine
    .HasTitle = True
    .ChartTitle.Text = ChartTitle
    .SetSourceData Source:=RetRange 'change this to be the table
    .Axes(xlValue).MaximumScaleIsAuto = True
    .Axes(xlCategory, xlPrimary).HasTitle = True
    .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Date"
    .Axes(xlValue, xlPrimary).HasTitle = True
    .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = secAxisTitle
    .Name = ChartSheetName
    .SetElement (msoElementLegendBottom)
    .Axes(xlCategory).TickLabelPosition = xlLow
    .Axes(xlCategory).MajorUnit = y * 30 ' <-- try this
    .Axes(xlCategory).MajorUnitScale = 30

    ' sets header names for modified sources
    Select Case ws.Name
        Case "Drawdown"
            For lColumn = 2 To LastColumn
                .FullSeriesCollection(lColumn - 1).Name = "=DD!$" & Col_Letter(lColumn) & "$1"
                .FullSeriesCollection(lColumn - 1).Values = "=DD!$" & Col_Letter(lColumn) & "$3:$" & Col_Letter(lColumn) & "$" & LastRow
            Next lColumn
        Case "Ret"
            For lColumn = 2 To LastColumn
                If ws.Cells(1, lColumn).Value <> "" Then
                    .FullSeriesCollection(lColumn - 1).Name = "='Ret'!$" & Col_Letter(lColumn) & "$1"
                Else
                    .FullSeriesCollection(lColumn - 1).Name = ""
                End If
            Next lColumn
        Case "Vol"
            For lColumn = 2 To LastColumn
                If ws.Cells(1, lColumn).Value <> "" Then
                    .FullSeriesCollection(lColumn - 1).Name = "='Vol'!$" & Col_Letter(lColumn) & "$1"
                Else
                    .FullSeriesCollection(lColumn - 1).Name = ""
                End If
            Next lColumn
    End Select
End With

'deleting the extra empty series
Dim nS As Series
'this has to be fixed. For a permanent solution, try to use tables
For Each nS In RetChart.SeriesCollection
    Select Case nS.Name
        Case "Series2", "Series3", "Series4", "Series5", ""
            nS.Delete
    End Select
Next nS

Set RetChart = Nothing

End Function

'=======================================================================

Function Col_Letter(lngCol As Long) As String

    Dim vArr
    vArr = Split(Worksheets("TIME SERIES").Cells(1, lngCol).Address(True, False), "$")
    Col_Letter = vArr(0)

End Function
Источник
Другие вопросы по тегам