如何创建折线图？

Question

我想为一组记录创建折线图(带标记的二维折线图)。

Excel选项卡的屏幕截图

​

(a)每三行代表一组待绘制的图表。第四列，虽然看起来是这样，但不需要用图表表示。截图中有18行，共6组记录。

(b)每套纪录须有一张折线图。因此，总共需要自动创建六个图表。

(c)此外，图表将在不同的Excel选项卡中创建。每个选项卡三个图表，因此这应该创建两个Excel选项卡，每个选项卡中放置三个图表。

Answer 1

我已经为在excel中使用VBA宏自动生成图表准备了一些代码，看看这是否有帮助。

下面的代码将为excel中可用的数据生成图表：

Dim Startrow As String
Dim Lastrow As String
Dim Lastcolumn As String
Dim ws1 As String
Dim cs2 As String
Dim cs3 As String
Dim ws(100)
Dim count As String
Dim i As Integer


Sub Final()
For j = 2 To Sheets.count
    count = Sheets.count
    Sheet1.Activate
    Cells(i, 1) = Sheets(i).Name
    'ws(i) = Sheets(i).Name
    'MsgBox Sheets.Count
    'MsgBox count
    'MsgBox ws(i)
Next

For i = 2 To count
    MsgBox count
    MsgBox i
    Sheet1.Activate
    ws(i) = Cells(i, 1)
    Sheets(ws(i)).Activate
    'Sheets(ws(i)).Activate
    MsgBox ws(i)
    'MsgBox Range("B1")
    'MsgBox IsEmpty(Range("B2"))
    If IsEmpty(Range("B1")) = False Then
        Startrow = 2
        'MsgBox Startrow
        Lastrow = Cells(Rows.count, 1).End(xlUp).Row
        'MsgBox Lastrow
        Lastcolumn = Split(Columns(Range("A1").End(xlToRight).Column).Address(, False), ":")(1)
        'MsgBox Lastcolumn
        Call test1
        MsgBox i
    End If
Next

End Sub

Function test1()

Dim letter As String
Dim letter1 As String
Dim letter2 As String
Dim letter3 As String

Dim x As Integer
MsgBox ws(i)
x = Range(Lastcolumn & 1).Column
'MsgBox x

Dim cs As Worksheet
Set cs = ThisWorkbook.Sheets.Add
'ws.name = "PrivateBytes_000005_Charts"
'ws2 = "PrivateBytes_000005_Charts"
cs.Name = ws(i) + "_Charts"
'MsgBox ws.Name
cs2 = ws(i) + "_Charts"
MsgBox cs2
cs3 = ws(i)
MsgBox cs3

If x < 27 Then

    For i = 2 To x



        letter3 = Chr(64 + i)

        'chart command

          Sheets(cs2).Activate
          ActiveSheet.Shapes.AddChart2(227, xlLineStacked).Select
          ActiveChart.SetSourceData Source:=Sheets(cs3).Range("A" & Startrow & ":A" & Lastrow & "," & letter3 & Startrow & ":" & letter3 & Lastrow)

          With ActiveChart
              .HasTitle = True
              Sheets(cs3).Activate
              .ChartTitle.Text = Range(letter3 & "1").Value
              .Axes(xlCategory, xlPrimary).HasTitle = False
              .Axes(xlValue, xlPrimary).HasTitle = False
          End With

    Next

End If

If x >= 27 Then

    For i = 2 To 26

        letter3 = Chr(64 + i)


        'chart command

        Sheets(cs2).Activate
        ActiveSheet.Shapes.AddChart2(227, xlLineStacked).Select
        ActiveChart.SetSourceData Source:=Sheets(cs3).Range("A" & Startrow & ":A" & Lastrow & "," & letter3 & Startrow & ":" & letter3 & Lastrow)


          With ActiveChart
              .HasTitle = True
              Sheets(cs3).Activate
              .ChartTitle.Text = Range(letter3 & "1").Value
              .Axes(xlCategory, xlPrimary).HasTitle = False
              .Axes(xlValue, xlPrimary).HasTitle = False
          End With

    Next

    For i = 27 To x

        letter3 = Chr(Int((i - 1) / 26) + 64) & Chr(((i - 1) Mod 26) + 65)
        'MsgBox letter3

        'chart command

        Sheets(cs2).Activate
        ActiveSheet.Shapes.AddChart2(227, xlLineStacked).Select
        ActiveChart.SetSourceData Source:=Sheets(cs3).Range("A" & Startrow & ":A" & Lastrow & "," & letter3 & Startrow & ":" & letter3 & Lastrow)

          With ActiveChart
              .HasTitle = True
              Sheets(cs3).Activate
              .ChartTitle.Text = Range(letter3 & "1").Value
              .Axes(xlCategory, xlPrimary).HasTitle = False
              .Axes(xlValue, xlPrimary).HasTitle = False
          End With

    Next
End If

Sheets(cs.Name).Activate
ActiveChart.Parent.Name = "Test1"
Call AutoSpace_Shapes_Vertical
'Return
'Unload UserForm1
End Function
Function AutoSpace_Shapes_Vertical()

'Automatically space and align shapes
    Sheets(cs2).Activate
    ActiveSheet.ChartObjects("Test1").Activate
    ActiveSheet.Shapes.SelectAll


Dim shp As Shape
Dim lCnt As Long
Dim dTop As Double
Dim dLeft As Double
Dim dHeight As Double
Const dSPACE As Double = 8

  'Check if shapes are selected
  If TypeName(Selection) = "Range" Then
    MsgBox "Please select shapes before running the macro."
    Exit Function
  End If

  'Set variables
  lCnt = 1

  'Loop through selected shapes (charts, slicers, timelines, etc.)
  For Each shp In Selection.ShapeRange
    With shp
      'If not first shape then move it below previous shape and align left.
      If lCnt > 1 Then
        .Top = dTop + dHeight + dSPACE
        .Left = dLeft
      End If

      'Store properties of shape for use in moving next shape in the collection.
      dTop = .Top
      dLeft = .Left
      dHeight = .Height
    End With

    'Add to shape counter
    lCnt = lCnt + 1

  Next shp
End Function
'End Sub
'End Sub

enter image description here