在Excel中使用VBA宏为每行创建一个新图表

Question

首先，也是最重要的，让我说这个网站是天赐的！

我有一个数据范围B2:AS40，每个月。月份在A2:AS2中，A2:A40中是一个名字列表，所有这些都在'Sheet1‘中。

在之前对这里进行了一些搜索之后，我得出了以下结论:该脚本为每一行创建一个新的图表，创建一个标题，并以6个月的间隔放入MajorGridlines，但不绘制数据。我无论如何也想不出为什么！

请帮帮忙

Sub test()
 Dim Row As Integer
 Dim ws As Worksheet
 Dim rng As Range

 Set ws = Sheets("Sheet1") 'Change this to: Set ws = Sheets("Master Sheet")

 For Row = 3 To 5
 Set rng = ws.Range("B3:AS3").Offset(Row, 0) 'Change to (I'm guessing here): ws.Range("$J$7:$Y$7").Offset(Row, 0)

 ActiveSheet.Shapes.AddChart.Select
 ActiveChart.SetSourceData Source:=Range(ws.Name & "!" & rng.Address)
 ActiveChart.ChartType = xlLineMarkers
 ActiveChart.PlotArea.Select
 ActiveChart.SeriesCollection(1).XValues = "='Sheet1'!$B$1:$AS$1" 'Change to "='Master Sheet'!$J$2:$Y$2"
 ActiveChart.SeriesCollection(1).Name = ws.Range("A1").Offset(Row, 0).Value 'Change this to whatever you want to name the graphs. This is currently set to dynamicly name each graph by the series name set in Column A.
 ActiveChart.Location Where:=xlLocationAsNewSheet, Name:=ws.Range("A1").Offset(Row, 0).Value  'uncomment this line to put on new sheet
 With ActiveChart
 .HasLegend = False
 .SeriesCollection(1).Trendlines.Add(Type:=xlMovingAvg, Period:=12).Select
 '.Axes(xlCategory).TickMarkSpacing = 6
 .Axes(xlCategory).HasMajorGridlines = True
 End With
 With ActiveChart.SeriesCollection(1).Trendlines(1)
    .Border.ColorIndex = 33
    .Border.Weight = xlMedium
    .Border.LineStyle = xlDashDotDot
 End With

ws.Select 'Need to go back to worksheet


 Next Row

 Set ws = Nothing
 Set rng = Nothing
End Sub

示例数据：

Apr-10  May-10  Jun-10  Jul-10  Aug-10  Sep-10  Oct-10  Nov-10  Dec-10  Jan-11  Feb-11  Mar-11  Apr-11  May-11  Jun-11  Jul-11  Aug-11  Sep-11  Oct-11  Nov-11  Dec-11  Jan-12  Feb-12  Mar-12  Apr-12  May-12  Jun-12  Jul-12  Aug-12  Sep-12  Oct-12  Nov-12  Dec-12  Jan-13  Feb-13  Mar-13  Apr-13  May-13  Jun-13  Jul-13  Aug-13  Sep-13  Oct-13  Nov-13
Company 1   14666   12795   10874   12560   13098   12660   14618   14031   14654   13016   11012   13912   14038   12262   12997   11295   12899   12878   14922   10493   13714   11513   12385   10528   13025   11637   11856   14794   10874   13286   12393   10164   11660   14948   13325   12689   14623   10368   10476   10386   11751   13766   11134   10497
Company 2   11769   10449   10835   12071   14354   12432   13698   14426   11763   11685   14876   12118   10110   12837   10144   10169   12664   11393   12613   13239   13681   14312   10848   14293   11270   14623   13738   12481   12226   11837   13960   12567   11668   12646   10829   11439   13698   10678   11409   13652   11056   13503   13182   14675
Company 3   13181   11246   11815   14960   11481   10863   10259   12287   13468   10454   12553   14751   10559   13592   14844   10799   11323   13218   13711   12547   14410   14205   10713   13059   12439   14185   11543   11537   11848   11150   12130   14641   13330   12934   12037   14982   11709   10971   13810   10729   13842   14457   14361   13281
Company 4   12223   13097   12032   10047   13361   12067   14420   11880   12270   10718   12367   12327   12542   13593   14858   14567   10096   10166   10580   13860   14581   12268   11613   11423   10472   13811   10801   13333   10324   12594   12745   12127   10944   10979   14404   14943   11067   12009   14457   10598   13409   13781   11553   13000
Company 5   13680   14319   13858   14356   13666   11855   11495   11406   14980   11369   10108   13726   11543   11311   12884   14486   10538   11346   14347   13568   14763   10218   14278   13355   13286   11899   13436   13980   14459   13648   14930   14999   12706   14181   11793   12777   14802   11914   10000   11245   13331   10915   11646   10435
Company 6   10083   10355   12951   13342   11059   13582   11118   14696   10608   11010   13741   13970   11800   13850   12179   13557   14757   13859   13297   14772   13896   11726   13055   13703   10883   11561   12175   13169   12040   10099   11165   12276   11627   12743   12092   12465   10375   10382   11125   14841   13409   12030   13165   12947
Company 7   12146   13011   14596   13182   13859   14605   13945   13826   14808   10528   12939   12123   12995   10259   12733   12132   13464   10246   11535   10440   14336   10856   10514   14316   13434   10513   10310   13833   13510   13442   11008   14883   12794   14255   13858   14184   10891   10429   14478   14679   13519   10498   10731   12438
Company 8   14815   13134   11152   13517   14849   12229   12884   10379   11917   11030   14059   10568   10975   14141   12078   12463   10602   12129   13460   10327   12262   11740   11278   13873   12184   13846   13275   10480   13078   13244   12005   12734   11160   14214   14511   14042   12153   12066   14280   11756   10621   13704   14137   13754
Company 9   14484   10161   14949   11218   14022   13369   11816   14573   14007   14962   13764   10730   14864   13414   11457   13405   10155   13868   13413   11129   12582   11212   13365   11107   13251   13103   12726   12545   14518   12512   12531   10677   12821   10819   10632   11638   12649   11437   10981   12661   11761   13174   13753   12176
Company 10  12523   14590   12610   10071   10965   14594   11908   14258   13927   10058   10496   11185   14372   12343   14455   11573   10534   10864   10814   12513   14356   10763   11413   10717   12409   14452   12473   11120   14296   12602   12950   12613   13964   14978   10129   13718   14289   13837   14312   12038   10796   10430   12051   11567

将脚本更改为以下内容后：

脚本不会在每次运行时都换行，它在新页面上生成的第二个图形只是将其余的图形堆积在上面！

开始发疯了！:(

Sub test()
    Dim Row As Long
    Dim ws As Worksheet
    Dim rng As Range

    Set ws = Sheets("Sheet1")

    For Row = 3 To 4
        Set rng = ws.Range("B3:AS3")
        ActiveSheet.Shapes.AddChart.Select

        With ActiveChart
            .SetSourceData Source:=Range(ws.Name & "!" & rng.Address)
            .ChartType = xlLineMarkers
            .PlotArea.Select
            .SeriesCollection(1).XValues = "='Sheet1'!$A2:$AS2"
            .SeriesCollection(1).Name = ws.Range("A1")
            .HasLegend = False
            .SeriesCollection(1).Trendlines.Add(Type:=xlMovingAvg, Period:=12).Select
            .Axes(xlCategory).HasMajorGridlines = True
            With .SeriesCollection(1).Trendlines(1)
               .Border.ColorIndex = 33
               .Border.Weight = xlMedium
               .Border.LineStyle = xlDashDotDot
            End With
        End With
        ActiveChart.Location Where:=xlLocationAsNewSheet, Name:=ws.Range("A1").Offset(Row, 0).Value
     Next Row

    Set rng = Nothing
    Set ws = Nothing
End Sub

Answer 1

这是你想要的我的版本：

使用工作簿对进行了尝试和测试

Option Explicit
Sub test()

Dim ws As Worksheet
Dim ch As Chart
Dim trend As Trendline
Dim rng As Range
Dim i As Long

Set ws = ThisWorkbook.Sheets("Sheet1")
Set rng = ws.Range("$A$3:$AS$3")

For i = 0 To 39
With ws
    Set ch = .Shapes.AddChart.Chart.Location(xlLocationAsNewSheet, .Range("A3").Offset(i, 0))
    ch.ChartType = xlLineMarkers
    ch.SetSourceData Source:=Range(.Name & "!" & rng.Offset(i, 0).Address)
    ch.SeriesCollection(1).XValues = "=Sheet1!$B$2:$AS$2"
    Set trend = ch.SeriesCollection(1).Trendlines.Add(xlMovingAvg, 12)
    With trend.Border
        .ColorIndex = 33
        .Weight = xlMedium
        .LineStyle = xlDashDotDot
    End With
    Set ch = Nothing
    Set trend = Nothing
End With
Next

Set rng = Nothing
Set ws = Nothing

End Sub

我坚持使用偏移量，并声明了大多数图表对象。

希望这能对你有所帮助。

使用您最近上传的图表查看示例图表的屏幕截图。

Company1，示例数据中的第一组数据：

​

前几列为0的Company3：

​

最后几列为零的Company40：

​