在 excel VBA 中创建图表
Creating a graph in excel VBA
代码的作用：我有一个代码，它从某些工作表中读取并使用数据创建图表。
我之前做了什么： 以前，我使用浮动方法（例如使用的范围和最后一个单元格）定义此图的范围。由于删除一行数据时出现问题（参见）我更改了引用方法，以考虑non-empty列的数量headers。
问题：虽然代码似乎对创建的第一个图表有效，但对于其他图表（在它到达第二列数据之前）它产生了一个在下面指示的行中出现错误（object 轴的方法 "major Unit" 失败）。
预期的结果：在我更改范围的参考程序之前，我没有遇到这些问题，并且图表构建正确。
问题：有什么可能导致此问题的想法吗？
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) & ""
.FullSeriesCollection(lColumn - 1).Values = "=DD!$" & Col_Letter(lColumn) & ":$" & 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) & ""
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) & ""
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
尝试下面的代码，我 "cleand" 它一点点，看看它是否解决了设置 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) & ""
.FullSeriesCollection(lColumn - 1).Values = "=DD!$" & Col_Letter(lColumn) & ":$" & 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) & ""
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) & ""
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
代码的作用：我有一个代码，它从某些工作表中读取并使用数据创建图表。
我之前做了什么： 以前，我使用浮动方法（例如使用的范围和最后一个单元格）定义此图的范围。由于删除一行数据时出现问题（参见
问题：虽然代码似乎对创建的第一个图表有效，但对于其他图表（在它到达第二列数据之前）它产生了一个在下面指示的行中出现错误（object 轴的方法 "major Unit" 失败）。
预期的结果：在我更改范围的参考程序之前，我没有遇到这些问题，并且图表构建正确。
问题：有什么可能导致此问题的想法吗？
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) & ""
.FullSeriesCollection(lColumn - 1).Values = "=DD!$" & Col_Letter(lColumn) & ":$" & 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) & ""
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) & ""
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
尝试下面的代码，我 "cleand" 它一点点，看看它是否解决了设置 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) & ""
.FullSeriesCollection(lColumn - 1).Values = "=DD!$" & Col_Letter(lColumn) & ":$" & 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) & ""
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) & ""
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