返回列表 上一主題 發帖

[發問] 動態修正匯入圖表的最後資料列之列數所延伸的問題

回復 33# c_c_lai
重新 修改整理 你的 程式碼 , 請將全部的程式碼 複製在同一模組中.
  1. Dim xRow(1 To 6), yCol(1 To 6), cWidth(1 To 6), cHeight(1 To 6), xText(1 To 6)
  2. Dim Chart_Source(1 To 6)
  3. Private Sub 陣列設定(ShName As String)
  4.     Dim Rng As Range
  5.     xRow(1) = IIf(ShName = "Omega", 4, 1)
  6.     xRow(2) = IIf(ShName = "Omega", 18, 16)
  7.     xRow(3) = IIf(ShName = "Omega", 4, 1)
  8.     xRow(4) = IIf(ShName = "Omega", 18, 16)
  9.     xRow(5) = IIf(ShName = "Omega", 4, 1)
  10.     xRow(6) = 31
  11.     yCol(1) = IIf(ShName = "Omega", 55, 1)
  12.     yCol(2) = IIf(ShName = "Omega", 35, 1)
  13.     yCol(3) = IIf(ShName = "Omega", 39, 5)
  14.     yCol(4) = IIf(ShName = "Omega", 39, 5)
  15.     yCol(5) = IIf(ShName = "Omega", 43, 9)
  16.     yCol(6) = 1
  17.     cWidth(1) = IIf(ShName = "Omega", 209, 222)
  18.     cWidth(2) = IIf(ShName = "Omega", 209, 222)
  19.     cWidth(3) = 209
  20.     cWidth(4) = 209
  21.     cWidth(5) = 405
  22.     cWidth(6) = 810
  23.     cHeight(1) = 240
  24.     cHeight(2) = 240
  25.     cHeight(3) = 240
  26.     cHeight(4) = 240
  27.     cHeight(5) = IIf(ShName = "Omega", 485, 488)
  28.     cHeight(6) = 480
  29.     xText(1) = "主力界入"
  30.     xText(2) = "力差"
  31.     xText(3) = "消化力"
  32.     xText(4) = "均差(大戶)"
  33.     xText(5) = "主力、散戶、與成交價、量"
  34.     xText(6) = "成交價與成交量"
  35.     With Sheets("統計圖表")
  36.         Set Rng = .Range("A1").CurrentRegion
  37.         Set Chart_Source(1) = Union(Rng.Columns(2), Rng.Columns(27))
  38.         Set Chart_Source(2) = Union(Rng.Columns(2), Rng.Columns(28))
  39.         Set Chart_Source(3) = Union(Rng.Columns(2), Rng.Columns(29))
  40.         Set Chart_Source(4) = Union(Rng.Columns(2), Rng.Columns(30))
  41.         Set Chart_Source(5) = Union(Rng.Columns(2), Rng.Columns(6), Rng.Columns(9), Rng.Columns(10), Rng.Columns(22))
  42.         Set Chart_Source(6) = Union(Rng.Columns(2), Rng.Columns(6), Rng.Columns(22))
  43.      End With
  44. End Sub
  45. Sub 全部重繪()  '重繪統計圖表 也是用此程序
  46.     製圖程序 Sheets(Array("統計圖表", "Omega"))
  47. End Sub
  48. Sub 重繪Omega()
  49.     製圖程序 Sheets(Array("Omega"))
  50. End Sub
  51. Private Sub 製圖程序(xlSh As Sheets)     '全部重繪
  52.     Dim Sh As Worksheet, xi As Integer
  53.     For Each Sh In xlSh   '"'Sheets(Array("統計圖表", "Omega"))
  54.         Sh.ChartObjects.Delete
  55.         陣列設定 Sh.Name
  56.         For xi = 1 To IIf(Sh.Name = "Omega", 5, 6)
  57.             With Sh.ChartObjects.Add(Sh.Cells(xRow(xi), yCol(xi)).Left, Sh.Cells(xRow(xi), yCol(xi)).Top, cWidth(xi), cHeight(xi)).Chart
  58.                 .ChartType = IIf(xi >= 5, xlLine, xlColumnStacked)  'xlLine-> 折線圖 'xlColumnStacke-> 堆疊直條圖
  59.                 .SetSourceData Source:=Chart_Source(xi)
  60.                 .HasLegend = 0                                          '圖表的圖例:  不可見
  61.                 .SeriesCollection(1).AxisGroup = IIf(xi >= 5, 2, 1)
  62.                 With .Axes(xlCategory)                'X座標軸
  63.                     .CategoryType = xlCategoryScale
  64.                     .TickLabels.NumberFormatLocal = "hh:mm"
  65.                     .MinorTickMark = xlNone
  66.                     .Border.Weight = xlHairline
  67.                     .Border.LineStyle = xlNone
  68.                     .TickLabelPosition = xlLow
  69.                     .TickLabels.Font.Size = 10
  70.                 End With
  71.                '''''''''''''''''''''''''
  72.                 If .ChartType = xlColumnStacked Then              '堆疊直條圖
  73.                     .SeriesCollection(1).Shadow = False           '圖表中的數列(1)
  74.                     .SeriesCollection(1).InvertIfNegative = True
  75.                     With .SeriesCollection(1).Border
  76.                         .Weight = xlHairline
  77.                         .LineStyle = xlNone
  78.                     End With
  79.                     With .SeriesCollection(1).Interior
  80.                         .ColorIndex = 5
  81.                         .PatternColorIndex = 42
  82.                         .Pattern = xlSolid
  83.                     End With
  84.                 Else                                               '折線圖
  85.                     .HasLegend = True
  86.                     .Legend.Top = 1
  87.                     .Legend.Position = xlCorner
  88.                     .SeriesCollection(1).MarkerStyle = xlNone
  89.                     With .Legend.Border
  90.                         .Weight = xlHairline
  91.                         .LineStyle = xlNone
  92.                     End With
  93.                 End If
  94.                 '''''''''''''''''''''''''''
  95.                 With .Axes(xlValue).TickLabels.Font   'Y座標軸上刻度的刻度標籤的字體
  96.                     .FontStyle = "標準"
  97.                     .Size = 10
  98.                 End With
  99.                 .HasTitle = True                        '圖表的標題   可見
  100.                  With .ChartTitle                       '圖表的標題
  101.                     .Top = 1
  102.                     .text = xText(xi)
  103.                     .Font.Size = 14
  104.                 End With
  105.                 With .PlotArea                          ' 圖表的繪圖區
  106.                     .Top = 1
  107.                     .Left = 1
  108.                     .Width = cWidth
  109.                     .Height = cHeight
  110.                     .Interior.ColorIndex = xlNone
  111.                 End With
  112.             End With
  113.         Next
  114.     Next
  115. End Sub
複製代碼

TOP

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

回復 35# c_c_lai
在2003版是沒這問題的 那稍加修改 如下
  1. Sub 全部重繪()  '重繪統計圖表 也是用此程序
  2.     製圖程序 "統計圖表"
  3.     重繪Omega
  4. End Sub
  5. Sub 重繪Omega()
  6.     製圖程序 "Omega"
  7. End Sub
  8. Private Sub 製圖程序(xlSh As String)      '全部重繪
  9.     Dim Sh As Worksheet, xi As Integer
  10.     Set Sh = Sheets(xlSh)
  11.     Sh.ChartObjects.Delete
  12.     陣列設定 Sh.Name
  13.     For xi = 1 To IIf(Sh.Name = "Omega", 5, 6)
  14.         With Sh.ChartObjects.Add(Sh.Cells(xRow(xi), yCol(xi)).Left, Sh.Cells(xRow(xi), yCol(xi)).Top, cWidth(xi), cHeight(xi)).Chart
  15.             .ChartType = IIf(xi >= 5, xlLine, xlColumnStacked)  'xlLine-> 折線圖 'xlColumnStacke-> 堆疊直條圖
  16.             .SetSourceData Source:=Chart_Source(xi)
  17.             .HasLegend = 0                                          '圖表的圖例:  不可見
  18.             .SeriesCollection(1).AxisGroup = IIf(xi >= 5, 2, 1)
  19.             With .Axes(xlCategory)                'X座標軸
  20.                 .CategoryType = xlCategoryScale
  21.                 .TickLabels.NumberFormatLocal = "hh:mm"
  22.                 .MinorTickMark = xlNone
  23.                 .Border.Weight = xlHairline
  24.                 .Border.LineStyle = xlNone
  25.                 .TickLabelPosition = xlLow
  26.                 .TickLabels.Font.Size = 10
  27.             End With
  28.             '''''''''''''''''''''''''
  29.             If .ChartType = xlColumnStacked Then              '堆疊直條圖
  30.                 .SeriesCollection(1).Shadow = False           '圖表中的數列(1)
  31.                 .SeriesCollection(1).InvertIfNegative = True
  32.                 With .SeriesCollection(1).Border
  33.                     .Weight = xlHairline
  34.                     .LineStyle = xlNone
  35.                 End With
  36.                 With .SeriesCollection(1).Interior
  37.                     .ColorIndex = 5
  38.                     .PatternColorIndex = 42
  39.                     .Pattern = xlSolid
  40.                 End With
  41.             Else                                               '折線圖
  42.                 .HasLegend = True
  43.                 .Legend.Top = 1
  44.                 .Legend.Position = xlCorner
  45.                 .SeriesCollection(1).MarkerStyle = xlNone
  46.                 With .Legend.Border
  47.                     .Weight = xlHairline
  48.                     .LineStyle = xlNone
  49.                 End With
  50.             End If
  51.                 '''''''''''''''''''''''''''
  52.             With .Axes(xlValue).TickLabels.Font   'Y座標軸上刻度的刻度標籤的字體
  53.                 .FontStyle = "標準"
  54.                 .Size = 10
  55.             End With
  56.             .HasTitle = True                        '圖表的標題   可見
  57.             With .ChartTitle                       '圖表的標題
  58.                 .Top = 1
  59.                 .text = xText(xi)
  60.                 .Font.Size = 14
  61.             End With
  62.             With .PlotArea                          ' 圖表的繪圖區
  63.                 .Top = 1
  64.                 .Left = 1
  65.                 .Width = cWidth
  66.                 .Height = cHeight
  67.                 .Interior.ColorIndex = xlNone
  68.             End With
  69.         End With
  70.     Next
  71. End Sub
複製代碼

TOP

回復 37# c_c_lai
上傳你的檔案看看

TOP

回復 39# c_c_lai
奇怪 我執行 Sub 全部重繪()  或 Sub 重繪Omega() 都沒問題阿
請問你是如何執行 Sub 全部重繪()  或 Sub 重繪Omega()

TOP

回復 41# c_c_lai
沒2010版 哪我也沒法度了

TOP

回復 43# c_c_lai
  1. Option Explicit
  2. Sub Ex()
  3.     Dim xRow(), i As Integer
  4.     xRow = Array(1, 2, 3, 4)    'xRow() 是為動態陣列
  5.     For i = 0 To 3
  6.         MsgBox xRow(i)
  7.     Next
  8. End Sub
  9. Sub Ex1()
  10.     Dim xRow(4), i As Integer
  11.     'xRow(4) 是為靜態陣列
  12.     '最小可使用的陣列索引 預設為 0  可用  Option Base {0 | 1} 來改變 是0 或 1
  13.     '最大可使用的陣列索引=4
  14.     'xRow = Array(1, 2, 3, 4,5)  '無法一次給值 ,靜態陣列 須 一一指定值
  15.     xRow(0) = 1
  16.     xRow(1) = 2
  17.     xRow(2) = 3
  18.     xRow(3) = 4
  19.     xRow(4) = 5
  20.     For i = 0 To 4
  21.         MsgBox xRow(i)
  22.     Next
  23. End Sub
  24. Sub Ex2()
  25.     Dim xRow(4 To 8), i As Integer
  26.     'xRow(4 to 8) 是為靜態陣列
  27.     '設定: 最小可使用的陣列索引 =4 , 最大可使用的陣列索引 = 8   
  28.     'xRow = Array(1, 2, 3, 4,5)  '無法一次給值 ,靜態陣列 須 一一指定值
  29.     xRow(4) = 1               '
  30.     xRow(5) = 2                '
  31.     xRow(6) = 3
  32.     xRow(7) = 4
  33.     xRow(8) = 5
  34.     For i = 4 To 8
  35.         MsgBox xRow(i)
  36.     Next
  37. End Sub
複製代碼

TOP

回復 45# c_c_lai
這太粗心,還是你細心的找出來,
我查出 2003版  這錯誤:
在圖表: 圖表區, 繪圖區.等 有可指定 Left ,Top, Width  ,Height 的地方
都可以接受這陣列不用索引值 , 會比照 先前使用過的索引值  如下
With Sh.ChartObjects.Add(Sh.Cells(xRow(xi), yCol(xi)).Left, Sh.Cells(xRow(xi), yCol(xi)).Top, cWidth(xi), cHeight(xi)).Chart


TOP

回復 47# c_c_lai
CurrentRegion 屬性 ,該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀。
  1. ActiveCell.CurrentRegion.Select
複製代碼
如圖 四個儲存格任選一個  執行  這程式碼 看看有何變化如何

TOP

        靜思自在 : 靜坐常恩己過、閒談莫論人非。
返回列表 上一主題