Excel中具有VBA的散点图在多个工作表上

Question

我正在处理一个宏，该宏将转到工作簿中的每个工作表，清理数据（添加列，更改单位等...）。 清除数据没有问题后，我尝试在工作表上创建散点图。 下面的代码省去了清理工作，因为它们无关紧要。 我尝试了许多迭代，包括记录宏，这是我的最后一次尝试。 最初来自单独的excel文件的工作表引起了问题。 每张纸具有相同的格式/组织结构，但是每张纸具有不同的列长（因为每张纸的数据长度根据实验持续的时间而有所不同）。 有没有人有什么建议？

Sub Cleaning()

    Application.ScreenUpdating = False

    For Each sh In Worksheets

        sh.Activate
        'find column length for loop
        Dim collength As Integer
        collength = Cells(Rows.Count, "A").End(xlUp).Row
        'plot curves
        ActiveSheet.Shapes.AddChart2(240, xlXYScatter).Select
        ActiveChart.SetSourceData Source:=Range(ActiveSheet.Name & "!$C$1:$C$" & collength, ActiveSheet.Name & "!$Q$1:$Q$" & collength)

    Next sh

    Application.ScreenUpdating = True

End Sub

在第二次尝试中，我尝试了此操作……仍然没有运气。

Dim strx As String
Dim stry As String
Dim rngx As Range
Dim rngy As Range

strx = "=" & ActiveSheet.Name & "!$C$2:$C$" & collength
stry = "=" & ActiveSheet.Name & "!$Q$2:$Q$" & collength

Dim Chart1 As Chart
    Set Chart1 = Charts.Add
    With Chart1
        .ChartType = xlXYScatter
        .SeriesCollection.NewSeries
        'Change to what your series should be called
        .SeriesCollection(1).Name = "=""Values"""
        .SeriesCollection(1).XValues = "=" & rngx
        .SeriesCollection(1).Values = "=" & rngy
    End With

在我的第三次尝试中，我记录了一个宏并对其进行了编辑以自动调整为活动工作表的列长，但是，最后一行出现1004错误。

Sub plotting_test()

Application.ScreenUpdating = False
For Each sh In Worksheets
   sh.Activate
'find column length for loop
    Dim collength As Integer
    collength = Cells(Rows.Count, "A").End(xlUp).Row
   '[B3].Value = collength


    Range("C1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range("B1:B" & collength & ",Q1").Select
    Range("Q1").Activate
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Shapes.AddChart2(240, xlXYScatter).Select
    ActiveChart.SetSourceData Source:=Range( _
        ActiveSheet.Name & "!$B$1:$B$" & collength & "," & ActiveSheet.Name & "!$Q$1:$Q$" & collength)


Next sh
Application.ScreenUpdating = True

End Sub

Answer 1

以下代码不会产生任何错误，并且会根据您提供的数据生成一个图形：

Sub mysub()
Dim sh As Worksheet

Application.ScreenUpdating = False
For Each sh In Worksheets
sh.Activate
'find column length for loop
Dim collength As Integer
collength = Cells(Rows.Count, "A").End(xlUp).Row
'[B3].Value = collength

Range("C1").Select
Range(Selection, Selection.End(xlDown)).Select
Range("B1:B" & collength & ",Q1").Select
Range("Q1").Activate
Range(Selection, Selection.End(xlDown)).Select
sh.Shapes.AddChart2(240, xlXYScatter).Select
ActiveChart.SetSourceData Source:=Range( _
ActiveSheet.Name & "!$B$1:$B$" & collength & "," & ActiveSheet.Name & "!$Q$1:$Q$" & collength)

Next sh
Application.ScreenUpdating = True

End Sub

无论如何，基本上就是您的代码，减去Sub名称和Dim sh As Worksheet。

由于无论如何都要遍历sh，因此使用它而不是Activesheet是有意义的。 因此，sh.Name将为您提供当前的工作表名称，但是总的来说，您的代码有效。 您是否可以提供有关可能得到的，意料之外的任何进一步的信息，还可以提供一些数据样本以尝试进一步提供帮助？

Answer 2

我终于想通了！ 该代码进入每个工作表，清理数据并正确格式化其格式，然后绘制所需的序列图。

Sub clean_and_graph()

'start with the first sheet
Application.ScreenUpdating = False
For Each sh In Worksheets
   sh.Activate


'find the collength for the series entry
    Dim collength As Integer
    collength = Cells(Rows.Count, "A").End(xlUp).Row
'clean up the data
    'Inserting a Column at Column C
        Range("C1").EntireColumn.Insert
        [C1].Value = "time"

        'eqn for first row in column
        [C2].Value = "=if(B2>0,24*(B2-$B$2))"
        'autofill rest of columns and format data to general
        Range("C2:C" & collength).FillDown
        Columns(3).NumberFormat = "General"

    'create the chart as an object in the worksheet
    Dim myChtObj As ChartObject
    Set myChtObj = ActiveSheet.ChartObjects.Add _
        (Left:=100, Width:=375, Top:=75, Height:=225)
    myChtObj.Chart.SetSourceData Source:=Sheets(ActiveSheet.Name).Range("C2:Q" & collength)
    myChtObj.Chart.ChartType = xlXYScatterLines


    With myChtObj.Chart

        ' make an XY chart
        .ChartType = xlXYScatterLines

        ' remove extra series
        Do Until .SeriesCollection.Count = 0
            .SeriesCollection(1).Delete
        Loop
         With .SeriesCollection.NewSeries
        .Name = ActiveSheet.Range("Q1")
        .Values = ActiveSheet.Range("Q2:Q" & collength)
        .XValues = ActiveSheet.Range("C2:C" & collength)
        End With
    End With


'go to the next sheet
    Next sh
Application.ScreenUpdating = True

End Sub