Tạo một biểu đồ mới cho mỗi hàng bằng cách sử dụng Macro VBA trong Excel

Question

Đầu tiên và trước hết hãy để tôi chỉ nói trang web này là một ơn trời!

Tôi có một dải dữ liệu B2: AS40 cho mỗi tháng. Tháng là A2: AS2, trong A2: A40 là danh sách tên, tất cả điều này nằm trong 'Sheet1'

Sau một số tìm kiếm trước đây ở đây, tôi đã đưa ra những điều sau, tập lệnh tạo biểu đồ mới cho mỗi dòng, tạo ra một tiêu đề và đặt trong MajorGridlines tại khoảng cách 6mth tuy nhiên không âm mưu dữ liệu. Tôi không thể cho cuộc sống của tôi làm việc tại sao !!

Xin giúp

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 

mẫu dữ liệu:

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 

Sau khi thay đổi kịch bản như thế này:

Kịch bản doesnt có được một mọi dòng mới nó chạy và đồ thị 2 nó làm trên một trang mới chỉ chồng phần còn lại của đồ thị lên trên chúng!

Bắt đầu mất tinh thần của tôi! :(

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

Đây là phiên bản của tôi về những gì bạn muốn:.
thử và thử nghiệm sử dụng bảng tính của bạn

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 

tôi gắn bó với bằng cách sử dụng offset và tuyên bố hầu hết các đối tượng biểu đồ
Hy vọng điều này sẽ giúp ích một chút
Xem ảnh chụp màn hình của biểu đồ mẫu sử dụng biểu đồ tải lên gần đây của bạn bằng cách sử dụng biểu đồ tải lên gần đây của bạn

Company1 đó là tập đầu tiên của dữ liệu trong dữ liệu mẫu của bạn:

Company3 với vài cột đầu tiên không:

Company40 với vài cột cuối cùng không: