求助：用Excel VBA创建Levey-Jennings图时控制线无法铺满图表

需通过VBA创建包含均值±2.5×标准差控制线的Levey-Jennings散点图，目前控制线无法铺满整个图表范围，已尝试设置X轴为日期范围（minDate和maxDate）但未生效，现有代码如下：

Sub CreateLeveyJenningsPlotWithSelection()
    Dim ws As Worksheet
    Dim dataRange As Range
    Dim chartRange As Range
    Dim chartObject As chartObject
    Dim chartTitle As String
    Dim userInput1 As String
    Dim userInput2 As String
    Dim minDate As Date
    Dim maxDate As Date
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Blad1")
    
    ' Ask the user for row selection (e.g., "2:20")
    userInput1 = InputBox("Enter the first column index after header(e.g., 3)")
    userInput2 = InputBox("Enter the index number after the last column index.")
    
    ' Validate user input (optional)
    If Not IsNumeric(Left(userInput1, 1)) Or Not IsNumeric(Left(userInput2, 1)) Then
        MsgBox "Invalid input. Please enter valid row numbers."
        Exit Sub
    End If
    
    ' Set the data range based on user input (assuming column E)
    Set dataRange = ws.Range("F" & userInput1 & ":F" & userInput2)
    
    ' Calculate mean and standard deviation
    Dim meanMFI As Double
    Dim stdevMFI As Double
    meanMFI = Application.WorksheetFunction.Average(dataRange)
    stdevMFI = Application.WorksheetFunction.StDev(dataRange)
    
    ' Set control limits (e.g., 2 standard deviations)
    Dim upperLimit As Double
    Dim lowerLimit As Double
    upperLimit = meanMFI + 2.5 * stdevMFI
    lowerLimit = meanMFI - 2.5 * stdevMFI
    
    ' Set x-axis limits based on date data
    minDate = Application.WorksheetFunction.Min(ws.Range("C2:C" & userInput2))
    maxDate = Application.WorksheetFunction.Max(ws.Range("C2:C" & userInput2))
    
    ' Create a scatter plot
    Set chartObject = ws.ChartObjects.Add(Left:=100, Width:=375, Top:=75, Height:=225)
    
    ' Set the chart range (exclude header row)
    Set chartRange = dataRange.Resize(dataRange.Rows.Count - 1, dataRange.Columns.Count)
    
    With chartObject.Chart
        .ChartType = xlXYScatter
        .SetSourceData Source:=chartRange
        .HasTitle = True
        .chartTitle.Text = "Levey-Jennings Plot"
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Text = "Date"
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Text = "MFI Value"
        
        ' Add upper limit line
        .SeriesCollection.NewSeries
        .SeriesCollection(1).Name = "Upper Control Limit"
        .SeriesCollection(1).Values = Array(upperLimit, upperLimit)
        .SeriesCollection(1).XValues = Array(minDate, maxDate)
        .SeriesCollection(1).ChartType = xlLine
        .SeriesCollection(1).Format.Line.ForeColor.RGB = RGB(255, 0, 0) ' Red color
        
        ' Add lower limit line
        .SeriesCollection.NewSeries
        .SeriesCollection(2).Name = "Lower Control Limit"
        .SeriesCollection(2).Values = Array(lowerLimit, lowerLimit)
        .SeriesCollection(2).XValues = Array(minDate, maxDate)
        .SeriesCollection(2).ChartType = xlLine
        .SeriesCollection(2).Format.Line.ForeColor.RGB = RGB(255, 0, 0) ' Red color
        
                
        ' Add data points
        .SeriesCollection.NewSeries
        .SeriesCollection(3).Name = "Actual Data Points"
        .SeriesCollection(3).Values = dataRange
        .SeriesCollection(3).XValues = dataRange
        .SeriesCollection(3).XValues = Array(minDate, maxDate)
        .SeriesCollection(3).MarkerStyle = xlMarkerStyleCircle
        .SeriesCollection(3).MarkerSize = 5
        .SeriesCollection(3).Format.Line.Visible = False
    End With
End Sub

错误分析 #

1. 初始.SetSourceData Source:=chartRange仅绑定了F列数值，导致X轴默认识别该列数据而非日期列，后续设置控制线X值无法覆盖初始X轴范围
2. 数据点系列的XValues被错误覆盖为Array(minDate, maxDate)，导致数据点无法正确映射到对应日期，同时干扰X轴范围计算
3. 系列索引混乱：初始创建的系列为SeriesCollection(1)，后续新增控制线时直接修改该系列，覆盖了原始数据系列，导致图表数据逻辑错误

修正后的代码 #

Sub CreateLeveyJenningsPlotWithSelection()
    Dim ws As Worksheet
    Dim dataRange As Range
    Dim dateRange As Range
    Dim chartObject As ChartObject
    Dim userInput1 As String
    Dim userInput2 As String
    Dim minDate As Date
    Dim maxDate As Date
    
    ' 绑定工作表
    Set ws = ThisWorkbook.Sheets("Blad1")
    
    ' 获取用户输入的行范围
    userInput1 = InputBox("Enter the first row index after header(e.g., 3)")
    userInput2 = InputBox("Enter the last row index.")
    
    ' 输入验证
    If Not IsNumeric(userInput1) Or Not IsNumeric(userInput2) Then
        MsgBox "Invalid input. Please enter valid row numbers."
        Exit Sub
    End If
    
    ' 绑定数据列(F列)和日期列(C列)
    Set dataRange = ws.Range("F" & userInput1 & ":F" & userInput2)
    Set dateRange = ws.Range("C" & userInput1 & ":C" & userInput2)
    
    ' 计算均值和标准差
    Dim meanMFI As Double
    Dim stdevMFI As Double
    meanMFI = Application.WorksheetFunction.Average(dataRange)
    stdevMFI = Application.WorksheetFunction.StDev(dataRange)
    
    ' 计算上下控制线
    Dim upperLimit As Double
    Dim lowerLimit As Double
    upperLimit = meanMFI + 2.5 * stdevMFI
    lowerLimit = meanMFI - 2.5 * stdevMFI
    
    ' 获取日期范围
    minDate = Application.WorksheetFunction.Min(dateRange)
    maxDate = Application.WorksheetFunction.Max(dateRange)
    
    ' 创建图表对象
    Set chartObject = ws.ChartObjects.Add(Left:=100, Width:=375, Top:=75, Height:=225)
    
    With chartObject.Chart
        .ChartType = xlXYScatter
        
        ' 添加数据点系列
        .SeriesCollection.NewSeries
        With .SeriesCollection(1)
            .Name = "Actual Data Points"
            .Values = dataRange
            .XValues = dateRange
            .MarkerStyle = xlMarkerStyleCircle
            .MarkerSize = 5
            .Format.Line.Visible = False
        End With
        
        ' 添加上控制线
        .SeriesCollection.NewSeries
        With .SeriesCollection(2)
            .Name = "Upper Control Limit"
            .Values = Array(upperLimit, upperLimit)
            .XValues = Array(minDate, maxDate)
            .ChartType = xlLine
            .Format.Line.ForeColor.RGB = RGB(255, 0, 0)
        End With
        
        ' 添加下控制线
        .SeriesCollection.NewSeries
        With .SeriesCollection(3)
            .Name = "Lower Control Limit"
            .Values = Array(lowerLimit, lowerLimit)
            .XValues = Array(minDate, maxDate)
            .ChartType = xlLine
            .Format.Line.ForeColor.RGB = RGB(255, 0, 0)
        End With
        
        ' 设置图表标题和轴标题
        .HasTitle = True
        .ChartTitle.Text = "Levey-Jennings Plot"
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Text = "Date"
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Text = "MFI Value"
        
        ' 强制设置X轴范围，确保控制线铺满整个图表
        .Axes(xlCategory).MinimumScale = minDate
        .Axes(xlCategory).MaximumScale = maxDate
    End With
End Sub

关键修正说明 #

• 移除初始.SetSourceData，改为逐个添加系列，避免X轴被错误初始化
• 数据点系列的XValues绑定到日期列（C列），确保数据点正确映射到对应日期
• 调整系列添加顺序，先添加数据点再添加控制线，避免索引混乱
• 强制设置X轴的MinimumScale和MaximumScale为日期范围，确保控制线铺满整个图表宽度

内容的提问来源于stack exchange，提问作者aemilius89