0

代码的作用：我有一个代码，它从某些工作表中读取并使用数据创建图表。

我之前所做的：以前，我使用浮动方法（例如使用的范围和 lastcell）来定义此图的范围。由于删除一行数据时出现问题（请参阅动态引用 VBA 中的 UsedRange），我更改了引用方法，以考虑非空列标题的数量。

问题：虽然代码似乎对创建的第一个图有效，但对于其他图（以及在它到达第二列数据之前）它在行中产生错误（对象轴的方法“主要单元”失败）如下所示。

期望做什么：在我更改范围的参考程序之前，我没有遇到这些问题，并且图表正在正确构建。

问题：关于可能导致此问题的任何想法？

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
4

1 回答 1

0

试试下面的代码，我“清理”了一点，看看它是否解决了你在设置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
于 2017-02-27T15:35:30.113 回答