動態修正匯入圖表的最後資料列之列數所延伸的問題 - Excel程式區

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

31^# 跳轉到 »

發表於 2012-4-19 17:25 | 只看該作者

回復 29# GBKEE

我將此兩頁之畫面附上供參考：

01.png (76.61 KB)

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

32^#

發表於 2012-4-19 17:48 | 只看該作者

本帖最後由 GBKEE 於 2012-4-19 17:52 編輯

回復 31# c_c_lai
對不起 :你的版本較先進我不易偵錯
只有你導引新增圖表較簡易的方法, 之後你再依你的需求修改

Sub Ex()
Dim Rng As Range, xi As Integer
With ActiveSheet
.ChartObjects.Delete '圖表全部刪除
For xi = 0 To 4
' Set Rng = .[a1].Offset(, xi * 10) ' 間隔10欄
Set Rng = .[a1].Offset(xi * 15) ' 間隔15列
With .ChartObjects.Add(Rng.Left, Rng.Top, Rng.Resize(, 10).Width, Rng.Resize(10).Height).Chart
' .ChartObjects.Add(Left, Top, Width, Height) '圖表新增( 右邊位置, 上方位置 ,寬度, 高度 )
.SetSourceData Source:=Sheets("統計圖表").UsedRange.Columns(xi + 1), PlotBy:=xlColumns
.HasTitle = True
.ChartTitle.text = "圖表 " & xi + 1
End With
Next
End With
End Sub

複製代碼

TOP

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

33^#

發表於 2012-4-20 08:24 | 只看該作者

回復 32# GBKEE
我得到了一個心得，那就是當您圖表的資料來源指向非本工作表單時 (例如：要在 A工作表單繪製統計圖表、而來源資料卻在 B工作表單 )，
於重新在繪製時，時而正常，多時亂序。
但是經多次測試發現最重要的癥結是：當 A工作表單內容除了所需選擇按鈕外，無任何資料存在，一切正常。
*** 當 A工作表單內容除了所需選擇按鈕外，已經存在有其他的任何資料 (如附件之狀況)，少少執行正常、多時脫線亂序。
煩請幫忙看看，謝謝您！

被圖表弄得快要崩潰了.rar (185.92 KB)

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

34^#

發表於 2012-4-21 10:54 | 只看該作者

回復 33# c_c_lai
重新修改整理你的程式碼 , 請將全部的程式碼複製在同一模組中.

Dim xRow(1 To 6), yCol(1 To 6), cWidth(1 To 6), cHeight(1 To 6), xText(1 To 6)
Dim Chart_Source(1 To 6)
Private Sub 陣列設定(ShName As String)
Dim Rng As Range
xRow(1) = IIf(ShName = "Omega", 4, 1)
xRow(2) = IIf(ShName = "Omega", 18, 16)
xRow(3) = IIf(ShName = "Omega", 4, 1)
xRow(4) = IIf(ShName = "Omega", 18, 16)
xRow(5) = IIf(ShName = "Omega", 4, 1)
xRow(6) = 31
yCol(1) = IIf(ShName = "Omega", 55, 1)
yCol(2) = IIf(ShName = "Omega", 35, 1)
yCol(3) = IIf(ShName = "Omega", 39, 5)
yCol(4) = IIf(ShName = "Omega", 39, 5)
yCol(5) = IIf(ShName = "Omega", 43, 9)
yCol(6) = 1
cWidth(1) = IIf(ShName = "Omega", 209, 222)
cWidth(2) = IIf(ShName = "Omega", 209, 222)
cWidth(3) = 209
cWidth(4) = 209
cWidth(5) = 405
cWidth(6) = 810
cHeight(1) = 240
cHeight(2) = 240
cHeight(3) = 240
cHeight(4) = 240
cHeight(5) = IIf(ShName = "Omega", 485, 488)
cHeight(6) = 480
xText(1) = "主力界入"
xText(2) = "力差"
xText(3) = "消化力"
xText(4) = "均差(大戶)"
xText(5) = "主力、散戶、與成交價、量"
xText(6) = "成交價與成交量"
With Sheets("統計圖表")
Set Rng = .Range("A1").CurrentRegion
Set Chart_Source(1) = Union(Rng.Columns(2), Rng.Columns(27))
Set Chart_Source(2) = Union(Rng.Columns(2), Rng.Columns(28))
Set Chart_Source(3) = Union(Rng.Columns(2), Rng.Columns(29))
Set Chart_Source(4) = Union(Rng.Columns(2), Rng.Columns(30))
Set Chart_Source(5) = Union(Rng.Columns(2), Rng.Columns(6), Rng.Columns(9), Rng.Columns(10), Rng.Columns(22))
Set Chart_Source(6) = Union(Rng.Columns(2), Rng.Columns(6), Rng.Columns(22))
End With
End Sub
Sub 全部重繪() '重繪統計圖表也是用此程序
製圖程序 Sheets(Array("統計圖表", "Omega"))
End Sub
Sub 重繪Omega()
製圖程序 Sheets(Array("Omega"))
End Sub
Private Sub 製圖程序(xlSh As Sheets) '全部重繪
Dim Sh As Worksheet, xi As Integer
For Each Sh In xlSh '"'Sheets(Array("統計圖表", "Omega"))
Sh.ChartObjects.Delete
陣列設定 Sh.Name
For xi = 1 To IIf(Sh.Name = "Omega", 5, 6)
With Sh.ChartObjects.Add(Sh.Cells(xRow(xi), yCol(xi)).Left, Sh.Cells(xRow(xi), yCol(xi)).Top, cWidth(xi), cHeight(xi)).Chart
.ChartType = IIf(xi >= 5, xlLine, xlColumnStacked) 'xlLine-> 折線圖 'xlColumnStacke-> 堆疊直條圖
.SetSourceData Source:=Chart_Source(xi)
.HasLegend = 0 '圖表的圖例: 不可見
.SeriesCollection(1).AxisGroup = IIf(xi >= 5, 2, 1)
With .Axes(xlCategory) 'X座標軸
.CategoryType = xlCategoryScale
.TickLabels.NumberFormatLocal = "hh:mm"
.MinorTickMark = xlNone
.Border.Weight = xlHairline
.Border.LineStyle = xlNone
.TickLabelPosition = xlLow
.TickLabels.Font.Size = 10
End With
'''''''''''''''''''''''''
If .ChartType = xlColumnStacked Then '堆疊直條圖
.SeriesCollection(1).Shadow = False '圖表中的數列(1)
.SeriesCollection(1).InvertIfNegative = True
With .SeriesCollection(1).Border
.Weight = xlHairline
.LineStyle = xlNone
End With
With .SeriesCollection(1).Interior
.ColorIndex = 5
.PatternColorIndex = 42
.Pattern = xlSolid
End With
Else '折線圖
.HasLegend = True
.Legend.Top = 1
.Legend.Position = xlCorner
.SeriesCollection(1).MarkerStyle = xlNone
With .Legend.Border
.Weight = xlHairline
.LineStyle = xlNone
End With
End If
'''''''''''''''''''''''''''
With .Axes(xlValue).TickLabels.Font 'Y座標軸上刻度的刻度標籤的字體
.FontStyle = "標準"
.Size = 10
End With
.HasTitle = True '圖表的標題可見
With .ChartTitle '圖表的標題
.Top = 1
.text = xText(xi)
.Font.Size = 14
End With
With .PlotArea ' 圖表的繪圖區
.Top = 1
.Left = 1
.Width = cWidth
.Height = cHeight
.Interior.ColorIndex = xlNone
End With
End With
Next
Next
End Sub

複製代碼

TOP

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

35^#

發表於 2012-4-21 11:54 | 只看該作者

回復 34# GBKEE
老是打擾您也會感到不好意思的，但不巧的它出現如下的錯誤訊息，它又沒指出是哪裡，只得求助您了！

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

36^#

發表於 2012-4-21 14:36 | 只看該作者

本帖最後由 GBKEE 於 2012-4-21 14:37 編輯

回復 35# c_c_lai
在2003版是沒這問題的那稍加修改如下

Sub 全部重繪() '重繪統計圖表也是用此程序
製圖程序 "統計圖表"
重繪Omega
End Sub
Sub 重繪Omega()
製圖程序 "Omega"
End Sub
Private Sub 製圖程序(xlSh As String) '全部重繪
Dim Sh As Worksheet, xi As Integer
Set Sh = Sheets(xlSh)
Sh.ChartObjects.Delete
陣列設定 Sh.Name
For xi = 1 To IIf(Sh.Name = "Omega", 5, 6)
With Sh.ChartObjects.Add(Sh.Cells(xRow(xi), yCol(xi)).Left, Sh.Cells(xRow(xi), yCol(xi)).Top, cWidth(xi), cHeight(xi)).Chart
.ChartType = IIf(xi >= 5, xlLine, xlColumnStacked) 'xlLine-> 折線圖 'xlColumnStacke-> 堆疊直條圖
.SetSourceData Source:=Chart_Source(xi)
.HasLegend = 0 '圖表的圖例: 不可見
.SeriesCollection(1).AxisGroup = IIf(xi >= 5, 2, 1)
With .Axes(xlCategory) 'X座標軸
.CategoryType = xlCategoryScale
.TickLabels.NumberFormatLocal = "hh:mm"
.MinorTickMark = xlNone
.Border.Weight = xlHairline
.Border.LineStyle = xlNone
.TickLabelPosition = xlLow
.TickLabels.Font.Size = 10
End With
'''''''''''''''''''''''''
If .ChartType = xlColumnStacked Then '堆疊直條圖
.SeriesCollection(1).Shadow = False '圖表中的數列(1)
.SeriesCollection(1).InvertIfNegative = True
With .SeriesCollection(1).Border
.Weight = xlHairline
.LineStyle = xlNone
End With
With .SeriesCollection(1).Interior
.ColorIndex = 5
.PatternColorIndex = 42
.Pattern = xlSolid
End With
Else '折線圖
.HasLegend = True
.Legend.Top = 1
.Legend.Position = xlCorner
.SeriesCollection(1).MarkerStyle = xlNone
With .Legend.Border
.Weight = xlHairline
.LineStyle = xlNone
End With
End If
'''''''''''''''''''''''''''
With .Axes(xlValue).TickLabels.Font 'Y座標軸上刻度的刻度標籤的字體
.FontStyle = "標準"
.Size = 10
End With
.HasTitle = True '圖表的標題可見
With .ChartTitle '圖表的標題
.Top = 1
.text = xText(xi)
.Font.Size = 14
End With
With .PlotArea ' 圖表的繪圖區
.Top = 1
.Left = 1
.Width = cWidth
.Height = cHeight
.Interior.ColorIndex = xlNone
End With
End With
Next
End Sub

複製代碼

TOP

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

37^#

發表於 2012-4-21 15:24 | 只看該作者

回復 36# GBKEE
錯誤訊息一樣，發現問題應該是出在 ----> 陣列設定上。

Dim xRow(1 To 6), yCol(1 To 6), cWidth(1 To 6), cHeight(1 To 6), xText(1 To 6)
Dim Chart_Source(1 To 6)
Private Sub 陣列設定(ShName As String)
Dim Rng As Range
xRow(1) = IIf(ShName = "Omega", 4, 1)
xRow(2) = IIf(ShName = "Omega", 18, 16)
xRow(3) = IIf(ShName = "Omega", 4, 1)
xRow(4) = IIf(ShName = "Omega", 18, 16)
xRow(5) = IIf(ShName = "Omega", 4, 1)
xRow(6) = 31
yCol(1) = IIf(ShName = "Omega", 55, 1)
yCol(2) = IIf(ShName = "Omega", 35, 1)
yCol(3) = IIf(ShName = "Omega", 39, 5)
yCol(4) = IIf(ShName = "Omega", 39, 5)
yCol(5) = IIf(ShName = "Omega", 43, 9)
yCol(6) = 1
cWidth(1) = IIf(ShName = "Omega", 209, 222)
cWidth(2) = IIf(ShName = "Omega", 209, 222)
cWidth(3) = 209
cWidth(4) = 209
cWidth(5) = 405
cWidth(6) = 810
cHeight(1) = 240
cHeight(2) = 240
cHeight(3) = 240
cHeight(4) = 240
cHeight(5) = IIf(ShName = "Omega", 485, 488)
cHeight(6) = 480
xText(1) = "主力界入"
xText(2) = "力差"
xText(3) = "消化力"
xText(4) = "均差(大戶)"
xText(5) = "主力、散戶、與成交價、量"
xText(6) = "成交價與成交量"
With Sheets("統計圖表")
Set Rng = .Range("A1").CurrentRegion
Set Chart_Source(1) = Union(Rng.Columns(2), Rng.Columns(27))
Set Chart_Source(2) = Union(Rng.Columns(2), Rng.Columns(28))
Set Chart_Source(3) = Union(Rng.Columns(2), Rng.Columns(29))
Set Chart_Source(4) = Union(Rng.Columns(2), Rng.Columns(30))
Set Chart_Source(5) = Union(Rng.Columns(2), Rng.Columns(6), Rng.Columns(9), Rng.Columns(10), Rng.Columns(22))
Set Chart_Source(6) = Union(Rng.Columns(2), Rng.Columns(6), Rng.Columns(22))
End With
End Sub