標題: VBA 畫圖方式請益????? [打印本頁]

---

作者: iverson105    時間: 2020-2-13 16:53     標題: VBA 畫圖方式請益?????

請教各位大大:
我有5個以上的sheets資料,想要自動抓取其中column的資料並畫成散布圖(資料sheet不一定,有時超個10個sheets .....請問以下程式會不會太常有可以簡短點嗎?
PS:如果我要畫第二張圖在同一張sheet內,應該怎麼寫(資料也是根據之前的sheet 但不同column)
以下是第一張圖的code:

1. Sub ALL_PLOT()
   
2. 
   
3. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   
4. '                                                                             '
   
5. '                               Plot Create                                  '
   
6. '                                                                             '
   
7. '                                                                             '
   
8. ' ''''''''''''''''''''''CHART(1) Ave.Ave. G.R. '''''''''''''''''''''''''''''''
   
9. 
   
10. ''''''''''''''''''''''''''Chart(1) Ave. G.R. / HSP ADD''''''''''''''''''''''''
    
11.   Sheets("R2R_analysis").Select
    
12.   ActiveSheet.Shapes.AddChart.Select
    
13.     ActiveChart.ChartType = xlXYScatter
    
14. 
    
15.    Dim aSh As Worksheet
    
16.     Application.ScreenUpdating = False
    
17.     For Each aSh In Worksheets
    
18.     If aSh.Name = "工作表1 (2)" Then
    
19.     Call polt_1
    
20.     ElseIf aSh.Name = "工作表1 (3)" Then
    
21.     Call polt_2
    
22.     ElseIf aSh.Name = "工作表1 (4)" Then
    
23.     Call polt_3
    
24.     ElseIf aSh.Name = "工作表1 (5)" Then
    
25.     Call polt_4
    
26.     ElseIf aSh.Name = "工作表1 (6)" Then
    
27.     Call polt_5
    
28.    
    
29.      ElseIf aSh.Name = "工作表1 (7)" Then
    
30.     Call polt_6
    
31.    
    
32.      ElseIf aSh.Name = "工作表1 (8)" Then
    
33.     Call polt_7
    
34.    
    
35.      ElseIf aSh.Name = "工作表1 (9)" Then
    
36.     Call polt_8
    
37.      ElseIf aSh.Name = "工作表1 (10)" Then
    
38.     Call polt_9
    
39.    
    
40.    
    
41.     ElseIf aSh.Name = "工作表1 (11)" Then
    
42.     Call polt_10
    
43.     ElseIf aSh.Name = "工作表1 (12)" Then
    
44.       Call polt_11
    
45.       
    
46.    End If
    
47.         
    
48.         
    
49.   Next
    
50.     Application.ScreenUpdating = True
    
51.       
    
52. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
53.   ActiveChart.ApplyLayout (4)
    
54.    
    
55. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
56.    
    
57. Dim xRg As Range
    
58.      Dim xChart As ChartObject
    
59.     Set xRg = Range("A20:J50")
    
60.   Set xChart = ActiveSheet.ChartObjects(1)
    
61.    With xChart
    
62.   .Top = xRg(1).Top
    
63. .Left = xRg(1).Left
    
64. .Width = xRg.Width
    
65. .Height = xRg.Height
    
66.    End With
    
67. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
68.    
    
69.    ActiveChart.SetElement (msoElementChartTitleAboveChart)
    
70.     Selection.Caption = "R2R_Ave.G.R."
    
71.     ActiveChart.SetElement (msoElementPrimaryValueAxisTitleRotated)
    
72.     Selection.Caption = "G.R.(mm/hr)"
    
73.     ActiveChart.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis)
    
74.     Selection.Caption = "Length(mm)"
    
75.    
    
76.     ActiveSheet.ChartObjects(1).Activate
    
77.     ActiveChart.Axes(xlCategory).Select
    
78.     ActiveChart.Axes(xlCategory).MinimumScale = 0
    
79.     ActiveChart.Axes(xlCategory).MaximumScale = 1100
    
80.     ActiveChart.Axes(xlCategory).MajorUnit = 100
    
81.     ActiveChart.Axes(xlCategory).MinorUnit = 50
    
82.     ActiveChart.Axes(xlCategory).CrossesAt = 0
    
83.     ActiveChart.Axes(xlValue).CrossesAt = 0
    
84. 
    
85.     ActiveChart.SetElement (msoElementPrimaryValueGridLinesMajor)
    
86.     ActiveChart.SetElement (msoElementPrimaryCategoryGridLinesMajor)
    
87.   
    
88. 
    
89.     Application.ScreenUpdating = True
    
90.   
    
91.   
    
92.   
    
93. 
    
94.   
    
95. End Sub
    
96. Sub polt_1()
    
97.    
    
98.     ActiveChart.SeriesCollection.NewSeries
    
99.     ActiveChart.SeriesCollection(1).Name = Sheets("工作表1 (2)").Range("U1")
    
100.     ActiveChart.SeriesCollection(1).XValues = "='工作表1 (2)'!$A$2:$A$20000"
     
101.     ActiveChart.SeriesCollection(1).Values = "='工作表1 (2)'!$D$2:$D$20000"
     
102.    
     
103. End Sub
     
104. Sub polt_2()
     
105.     ActiveChart.SeriesCollection.NewSeries
     
106.     ActiveChart.SeriesCollection(2).Name = Sheets("工作表1 (3)").Range("U1")
     
107.     ActiveChart.SeriesCollection(2).XValues = "='工作表1 (3)'!$A$2:$A$20000"
     
108.     ActiveChart.SeriesCollection(2).Values = "='工作表1 (3)'!$D$2:$D$20000"
     
109.    
     
110.   End Sub
     
111. 
     
112. Sub polt_3()
     
113.     ActiveChart.SeriesCollection.NewSeries
     
114.     ActiveChart.SeriesCollection(3).Name = Sheets("工作表1 (4)").Range("U1")
     
115.     ActiveChart.SeriesCollection(3).XValues = "='工作表1 (4)'!$A$2:$A$20000"
     
116.     ActiveChart.SeriesCollection(3).Values = "='工作表1 (4)'!$D$2:$D$20000"
     
117.    
     
118.   End Sub
     
119. 
     
120. Sub polt_4()
     
121.     ActiveChart.SeriesCollection.NewSeries
     
122.     ActiveChart.SeriesCollection(4).Name = Sheets("工作表1 (5)").Range("U1")
     
123.     ActiveChart.SeriesCollection(4).XValues = "='工作表1 (5)'!$A$2:$A$20000"
     
124.     ActiveChart.SeriesCollection(4).Values = "='工作表1 (5)'!$D$2:$D$20000"
     
125.    
     
126.   End Sub
     
127. 
     
128. Sub polt_5()
     
129.     ActiveChart.SeriesCollection.NewSeries
     
130.     ActiveChart.SeriesCollection(5).Name = Sheets("工作表1 (6)").Range("U1")
     
131.     ActiveChart.SeriesCollection(5).XValues = "='工作表1 (6)'!$A$2:$A$20000"
     
132.     ActiveChart.SeriesCollection(5).Values = "='工作表1 (6)'!$D$2:$D$20000"
     
133.    
     
134.   End Sub
     
135. 
     
136. 
     
137. Sub polt_6()
     
138.     ActiveChart.SeriesCollection.NewSeries
     
139.     ActiveChart.SeriesCollection(6).Name = Sheets("工作表1 (7)").Range("U1")
     
140.     ActiveChart.SeriesCollection(6).XValues = "='工作表1 (7)'!$A$2:$A$20000"
     
141.     ActiveChart.SeriesCollection(6).Values = "='工作表1 (7)'!$D$2:$D$20000"
     
142.    
     
143.   End Sub
     
144. 
     
145. Sub polt_7()
     
146.     ActiveChart.SeriesCollection.NewSeries
     
147.     ActiveChart.SeriesCollection(7).Name = Sheets("工作表1 (8)").Range("U1")
     
148.     ActiveChart.SeriesCollection(7).XValues = "='工作表1 (8)'!$A$2:$A$20000"
     
149.     ActiveChart.SeriesCollection(7).Values = "='工作表1 (8)'!$D$2:$D$20000"
     
150.    
     
151.   End Sub
     
152.   Sub polt_8()
     
153.     ActiveChart.SeriesCollection.NewSeries
     
154.     ActiveChart.SeriesCollection(8).Name = Sheets("工作表1 (9)").Range("U1")
     
155.     ActiveChart.SeriesCollection(8).XValues = "='工作表1 (9)'!$A$2:$A$20000"
     
156.     ActiveChart.SeriesCollection(8).Values = "='工作表1 (9)'!$D$2:$D$20000"
     
157.    
     
158.   End Sub
     
159.    Sub polt_9()
     
160.     ActiveChart.SeriesCollection.NewSeries
     
161.     ActiveChart.SeriesCollection(9).Name = Sheets("工作表1 (10)").Range("U1")
     
162.     ActiveChart.SeriesCollection(9).XValues = "='工作表1 (10)'!$A$2:$A$20000"
     
163.     ActiveChart.SeriesCollection(9).Values = "='工作表1 (10)'!$D$2:$D$20000"
     
164.    
     
165.   End Sub
     
166.    Sub polt_10()
     
167.     ActiveChart.SeriesCollection.NewSeries
     
168.     ActiveChart.SeriesCollection(10).Name = Sheets("工作表1 (11)").Range("U1")
     
169.     ActiveChart.SeriesCollection(10).XValues = "='工作表1 (11)'!$A$2:$A$20000"
     
170.     ActiveChart.SeriesCollection(10).Values = "='工作表1 (11)'!$D$2:$D$20000"
     
171.     End Sub
     
172. Sub polt_11()
     
173. ActiveChart.SeriesCollection.NewSeries
     
174.     ActiveChart.SeriesCollection(11).Name = Sheets("工作表1 (12)").Range("U1")
     
175.     ActiveChart.SeriesCollection(11).XValues = "='工作表1 (12)'!$A$2:$A$20000"
     
176.     ActiveChart.SeriesCollection(11).Values = "='工作表1 (12)'!$D$2:$D$20000"
     
177. End Sub

複製代碼

Tks

---

作者: jcchiang    時間: 2020-2-17 14:51

回復 1# iverson105

濃縮這樣,試試看
Sub ALL_PLOT()
Dim x As Integer
Sheets("R2R_analysis").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlXYScatter
Application.ScreenUpdating = False
For x = 2 To Worksheets.Count
   ActiveChart.SeriesCollection.NewSeries
   ActiveChart.SeriesCollection(x - 1).Name = Sheets("工作表1 (" & x & ")").Range("U1")
   ActiveChart.SeriesCollection(x - 1).XValues = Sheets("工作表1 (" & x & ")").Range("A2:A20000")
   ActiveChart.SeriesCollection(x - 1).Values = Sheets("工作表1 (" & x & ")").Range("D2:D20000")
Next
Application.ScreenUpdating = True

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ActiveChart.ApplyLayout (4)

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim xRg As Range
Dim xChart As ChartObject
Set xRg = Range("A20:J50")
Set xChart = ActiveSheet.ChartObjects(1)
With xChart
   .Top = xRg(1).Top
   .Left = xRg(1).Left
   .Width = xRg.Width
   .Height = xRg.Height
End With

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ActiveChart.SetElement (msoElementChartTitleAboveChart)
Selection.Caption = "R2R_Ave.G.R."
ActiveChart.SetElement (msoElementPrimaryValueAxisTitleRotated)
Selection.Caption = "G.R.(mm/hr)"
ActiveChart.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis)
Selection.Caption = "Length(mm)"
ActiveSheet.ChartObjects(1).Activate
ActiveChart.Axes(xlCategory).Select
ActiveChart.Axes(xlCategory).MinimumScale = 0
ActiveChart.Axes(xlCategory).MaximumScale = 1100
ActiveChart.Axes(xlCategory).MajorUnit = 100
ActiveChart.Axes(xlCategory).MinorUnit = 50
ActiveChart.Axes(xlCategory).CrossesAt = 0
ActiveChart.Axes(xlValue).CrossesAt = 0
ActiveChart.SetElement (msoElementPrimaryValueGridLinesMajor)
ActiveChart.SetElement (msoElementPrimaryCategoryGridLinesMajor)
Application.ScreenUpdating = True
End Sub

---

作者: jcchiang    時間: 2020-2-17 15:30

回復 2# jcchiang
第二個問題:如果我要畫第二張圖在同一張sheet內,應該怎麼寫(資料也是根據之前的sheet 但不同column)
因為不確定會畫幾張圖,所以程式會先詢問要畫幾次(如果只會畫2張就將y = Application.InputBox("畫圖次數", "")移除,For z = 1 To y改為For z = 1 To 2)
另外第二張以後的圖Column不知道會在哪裡,先當作再第一張圖Column往右擺放,如果位置差異較多就要再修改

Sub ALL_PLOT1()
Dim x, y, z As Integer
y = Application.InputBox("畫圖次數", "")
For z = 1 To y
Sheets("R2R_analysis").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlXYScatter
Application.ScreenUpdating = False
For x = 2 To Worksheets.Count
   ActiveChart.SeriesCollection.NewSeries
   ActiveChart.SeriesCollection(x - 1).Name = Sheets("工作表1 (" & x & ")").Range("U1").Offset(0, (z - 1))
   ActiveChart.SeriesCollection(x - 1).XValues = Sheets("工作表1 (" & x & ")").Range("A2:A20000").Offset(0, (z - 1))
   ActiveChart.SeriesCollection(x - 1).Values = Sheets("工作表1 (" & x & ")").Range("D2:D20000").Offset(0, (z - 1))
Next
Application.ScreenUpdating = True

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ActiveChart.ApplyLayout (4)

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim xRg As Range
Dim xChart As ChartObject
Set xRg = Range("A20:J50")
Set xChart = ActiveSheet.ChartObjects(z)
With xChart
   .Top = xRg(z).Top
   .Left = xRg(z).Left
   .Width = xRg.Width
   .Height = xRg.Height
End With

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ActiveChart.SetElement (msoElementChartTitleAboveChart)
Selection.Caption = "R2R_Ave.G.R." & z
ActiveChart.SetElement (msoElementPrimaryValueAxisTitleRotated)
Selection.Caption = "G.R.(mm/hr)"
ActiveChart.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis)
Selection.Caption = "Length(mm)"
ActiveSheet.ChartObjects(z).Activate
ActiveChart.Axes(xlCategory).Select
ActiveChart.Axes(xlCategory).MinimumScale = 0
ActiveChart.Axes(xlCategory).MaximumScale = 1100
ActiveChart.Axes(xlCategory).MajorUnit = 100
ActiveChart.Axes(xlCategory).MinorUnit = 50
ActiveChart.Axes(xlCategory).CrossesAt = 0
ActiveChart.Axes(xlValue).CrossesAt = 0
ActiveChart.SetElement (msoElementPrimaryValueGridLinesMajor)
ActiveChart.SetElement (msoElementPrimaryCategoryGridLinesMajor)
Application.ScreenUpdating = True
Next
End Sub

---

作者: iverson105    時間: 2020-2-19 11:41

回復 2# jcchiang

感謝大大的回覆
但在跑的時候出現錯誤????????
再麻煩指教!

謝謝

1. Sub ALL_PLOT_TEST()
   
2. Dim x As Integer
   
3. Sheets("R2R_analysis").Select
   
4. ActiveSheet.Shapes.AddChart.Select
   
5. ActiveChart.ChartType = xlXYScatter
   
6. Application.ScreenUpdating = False
   
7. For x = 2 To Worksheets.Count
   
8.    ActiveChart.SeriesCollection.NewSeries
   
9.    ActiveChart.SeriesCollection(x - 1).Name = Sheets("工作表1 (" & x & ")").Range("U1")   .....................................................(請問這段出錯誤(陣列索引 超出範圍) 要如何修正
   
10.    ActiveChart.SeriesCollection(x - 1).XValues = Sheets("工作表1 (" & x & ")").Range("A2:A20000")
    
11.    ActiveChart.SeriesCollection(x - 1).Values = Sheets("工作表1 (" & x & ")").Range("D2:D20000")
    
12. Next
    
13. Application.ScreenUpdating = True

複製代碼

---

作者: jcchiang    時間: 2020-2-19 12:29

回復 4# iverson105

這段是在抓工作表資料到圖表裡
你的工作表名稱是"工作表1 (2)",工作表1 (3)"...........以上嗎??
,可以上傳你的檔案嗎??這樣比較能知道原因

---

作者: iverson105    時間: 2020-2-19 13:57

感謝大大的指教
想在請問一下
以下的code
1.可以改成圖表放置的位置是依我只是的位置固定嗎(ex:Plot1 在 A20:J50  '  plot2在L20:U50........以此類推)
2.還有坐標軸可自己先寫在code中嗎? 因為每一張圖的座標軸明成不一樣

感謝

1. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   
2. Dim xRg As Range
   
3. Dim xChart As ChartObject
   
4. Set xRg = Range("A20:J50")..........................................................................................(問題1)
   
5. Set xChart = ActiveSheet.ChartObjects(z)
   
6. With xChart
   
7.    .Top = xRg(z).Top
   
8.    .Left = xRg(z).Left
   
9.    .Width = xRg.Width
   
10.    .Height = xRg.Height
    
11. End With
    
12. 
    
13. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
14. ActiveChart.SetElement (msoElementChartTitleAboveChart)
    
15. Selection.Caption = "R2R_Ave.G.R." & z...........................................................................................(問題2)
    
16. ActiveChart.SetElement (msoElementPrimaryValueAxisTitleRotated)
    
17. Selection.Caption = "G.R.(mm/hr)"..........................................................................................(問題2)
    
18. ActiveChart.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis)
    
19. Selection.Caption = "Length(mm)"

複製代碼

回復 3# jcchiang

---

作者: iverson105    時間: 2020-2-19 13:59

回復 5# jcchiang

好喔!  晚點傳
(上班中 工作電腦傳不出去)   

感謝

---

作者: jcchiang    時間: 2020-2-19 16:22

回復 6# iverson105

這樣未知的變數太多了
1.會畫幾張圖不知
2.名稱又要不一樣
3.每張圖座標又要不一樣
除非是先將圖表設定好要的名稱跟座標再將資料拋進去,
如果相關資料都不明的情況下,小弟才疏學淺可能寫不出來,就要請站上的大神指導囉

---

作者: jcchiang    時間: 2020-2-20 12:34

回復 6# iverson105
先輸入所需資料後,再將相關資料帶入圖表
如果有不夠的請依此方式增加要的資料

Sub ALL_PLOT2()
Dim x, y, z, R As Integer
Dim CName(10, 10)
R = 0
Do While y = ""                                          '防止資料為空白
   y = Application.InputBox("畫圖次數", "", 1, 350, 150) '輸入要畫幾張圖,預設為1張
   If y = "" Then MsgBox "畫圖次數不得為空白!!"
Loop
'----------------------------------輸入各圖表相關資料(所需資料自行增加)-----------
For z = 1 To y
Do While CName(z, 0) = ""
   CName(z, 0) = Application.InputBox("第" & z & "圖名", "", "R2R_Ave.G.R." & z, 350, 150) '輸入圖表名稱,預設為R2R_Ave.G.R.1
   If CName(z, 0) = "" Then MsgBox "請輸入圖名!!"
Loop
Do While CName(z, 1) = ""
   CName(z, 1) = Application.InputBox("第" & z & "圖的MinimumScale", "", "0", 350, 150)    '輸入x軸最小座標,預設為0
   If CName(z, 1) = "" Then MsgBox "MinimumScale不得為空白!!"
Loop
Do While CName(z, 2) = ""
   CName(z, 2) = Application.InputBox("第" & z & "圖的MaximumScale", "", "1000", 350, 150) '輸入x軸最大座標,預設為0
   If CName(z, 2) = "" Then MsgBox "MaximumScale不得為空白!!"
Loop
Next
'---------------------------------------------------------------
For z = 1 To y
Sheets("R2R_analysis").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlXYScatter
Application.ScreenUpdating = False
For x = 2 To Worksheets.Count
   ActiveChart.SeriesCollection.NewSeries
   ActiveChart.SeriesCollection(x - 1).Name = Sheets("工作表1 (" & x & ")").Range("U1").Offset(0, (z - 1))
   ActiveChart.SeriesCollection(x - 1).XValues = Sheets("工作表1 (" & x & ")").Range("A2:A20000").Offset(0, (z - 1))
   ActiveChart.SeriesCollection(x - 1).Values = Sheets("工作表1 (" & x & ")").Range("D2:D20000").Offset(0, (z - 1))
Next
Application.ScreenUpdating = True

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ActiveChart.ApplyLayout (4)

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim xRg As Range
Dim xChart As ChartObject
Set xRg = Range("A20:J50").Offset(0, R)
Set xChart = ActiveSheet.ChartObjects(z)
With xChart
   .Top = xRg(z).Top
   .Left = xRg(z).Left
   .Width = xRg.Width
   .Height = xRg.Height
End With

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ActiveChart.SetElement (msoElementChartTitleAboveChart)
Selection.Caption = CName(z, 0)
ActiveChart.SetElement (msoElementPrimaryValueAxisTitleRotated)
Selection.Caption = "G.R.(mm/hr)"
ActiveChart.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis)
Selection.Caption = "Length(mm)"
ActiveSheet.ChartObjects(z).Activate
ActiveChart.Axes(xlCategory).Select
ActiveChart.Axes(xlCategory).MinimumScale = CName(z, 1)
ActiveChart.Axes(xlCategory).MaximumScale = CName(z, 2)
ActiveChart.Axes(xlCategory).MajorUnit = 100
ActiveChart.Axes(xlCategory).MinorUnit = 50
ActiveChart.Axes(xlCategory).CrossesAt = 0
ActiveChart.Axes(xlValue).CrossesAt = 0
ActiveChart.SetElement (msoElementPrimaryValueGridLinesMajor)
ActiveChart.SetElement (msoElementPrimaryCategoryGridLinesMajor)
Application.ScreenUpdating = True
R = R + 10 '每張圖表位置間隔
Next
End Sub

---

作者: iverson105    時間: 2020-2-24 01:19

回復 9# jcchiang


    感謝大大的回覆 ,我再試一下,感應不盡


謝謝

---

作者: iverson105    時間: 2020-2-24 15:14

回復 9# jcchiang

感謝喔, 可以使用喔(可照我要的修改)


謝謝

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)