1234
返回列表 上一主題 發帖

請各位大大幫忙修改建立崁入圖表錯誤語法

lamihsuen

帖子
33 
主題
4 
精華
0 
積分
37 
點名
0  
作業系統
w7 
軟體版本
pro 
閱讀權限
10 
性別
女 
來自
台中 
註冊時間
2012-6-20 
最後登錄
2019-5-24 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-7-15 21:12 | 只看該作者

請各位大大幫忙修改建立崁入圖表錯誤語法

請各位大大幫忙   我想在Worksheets(wr)工作表中繪製圖表(建立崁入圖表)請問正確語法為何

如果下列變數定義如下數值
WR=4
z_sr =120
lRow= 150
chart_sr     =156
chart_end=166
'設定要崁入圖表的位置
Dim GR As Range
   Set GR = Worksheets(wr).Range("A" & chart_sr & " :I" & chart_end)'
    With Worksheets(wr).ChartObjects.Add(GR.Left, GR.Top, GR.Width, GR.Height)
'設定工作表名稱+"值"為圖表名稱
               Worksheets(wr).ChartObjects.name= Worksheets(wr).name&"值"
' 設定資料範圍為儲存格   Worksheets(wr).   RANRE ("A" & z_sr & " :C" & xlRow)
         Worksheets(wr).ChartObjects.SetSourceData.RANRE ("A" & z_sr & " :C" & xlRow)
請問設定圖表名稱.和設定圖表的資料範圍正確的語法為何?
收藏 分享

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
2#
發表於 2012-7-16 10:02 | 只看該作者
回復 1# lamihsuen
貼上 GBKEE 指導前輩曾經給我的範例，堤供妳參考，希望對妳會有實質的幫助。
又、妳打錯字了 .RANRE -> .RANGE。 (算粗心吧！:o )
  1. Private Sub 製圖()
  2.     Dim xR As Range, Xi As Integer, i As Integer, 圖色()

  4.     圖色 = Array(4, 6, 8, 10)

  6.     ActiveSheet.ChartObjects.Delete     '刪除全部圖表

  8.     Set xR = Range("F1")    '利用xR的位置 設下圖表的位置
  9.     '加入新圖表  須指定 1右邊位置, 2高度位置, 3圖表的Width, 4圖表的Height

  11.     With ChartObjects.Add(xR.Left, xR.Top, xR.Resize(, 10).Width, xR.Resize(10).Height).Chart
  12.     .ChartType = 51  ' xlLineMarkers    '折線圖         '圖表 式樣
  13.         With ActiveSheet.Range("A2").CurrentRegion
  14.             Set xR = Union(.Columns(1), .Columns(3), .Columns(5))
  15.             '資料 範圍的 1,3,5 欄為圖表資料  :第1欄 為x軸的數值
  16.         End With
  17.         .SetSourceData Source:=xR, PlotBy:=xlColumns
  18.         '圖表資料來源 : xR  資料式樣: 欄
  19.                      
  20.         .HasTitle = True              '顯示 圖表標題
  21.         .ChartTitle.Characters.Text = ActiveSheet.Name    'HasTitle = False 會有錯誤
  22.         .HasAxis(xlCategory, xlPrimary) = False           '不顯示 X軸座標
  23.                
  24.         'HasLegend 圖例
  25.         .HasLegend = False             ' 取消 顯示 圖例
  26.         '  .Legend.Position = xlTop           '顯示 圖例位置
  27.         ' .Axes(xlCategory).TickLabels.NumberFormatLocal = "m/d;@"    ' Axes(xlCategory) X座標軸
  28.         ' ** 上二式 須  顯示圖例 ->  .HasLegend = True
  29.                
  30.         '.SeriesCollection(1).AxisGroup = 2           '新增 Y座標軸 副座標軸
  31.         '  .SeriesCollection(3)).Delete     '刪除第3數列資料
  32.         With .Axes(xlValue)      'y軸格線
  33.             .HasMajorGridlines = 0   '取消 主格線
  34.             .HasMinorGridlines = 0   '取消 副格線
  35.         End With
  36.         '以下一些程式碼 你可用錄製得知
  37.         With .ChartArea             '圖表的圖表區
  38.             .Border.Weight = 1
  39.             .Border.LineStyle = -1
  40.             .Fill.OneColorGradient Style:=msoGradientHorizontal, Variant:=3, Degree:=0.231372549019608
  41.             .Fill.Visible = True
  42.             .Fill.ForeColor.SchemeColor = 圖色(0)
  43.         End With
  44.         With .PlotArea              '圖表的 繪圖區
  45.             .Fill.OneColorGradient Style:=msoGradientHorizontal, Variant:=1, _
  46.             Degree:=0.231372549019608
  47.             .Fill.Visible = True
  48.             .Fill.ForeColor.SchemeColor = 圖色(0)
  49.             With .Border
  50.             .ColorIndex = 16
  51.             .Weight = xlThin
  52.             .LineStyle = xlContinuous
  53.             End With
  54.         End With
  55.         For i = 1 To .SeriesCollection.Count
  56.             With .SeriesCollection(i)   '數列
  57.                 '  .XValues = ""       '<-為x軸的數值   可在此取消
  58.                 With .Border
  59.                 .ColorIndex = 圖色(i)
  60.                 .Weight = xlMedium
  61.                 .LineStyle = xlContinuous
  62.                 End With
  63.                 '以下屬性 只適合 折線圖
  64.                 ' .MarkerBackgroundColorIndex = xlAutomatic
  65.                 '.MarkerForegroundColorIndex = xlAutomatic
  66.                 '.MarkerStyle = xlNone
  67.                 '.Smooth = False
  68.                 '.MarkerSize = 7
  69.                 '.Shadow = False
  70.             End With
  71.         Next
  72.     End With
  73. End Sub
複製代碼

TOP

lamihsuen

帖子
33 
主題
4 
精華
0 
積分
37 
點名
0  
作業系統
w7 
軟體版本
pro 
閱讀權限
10 
性別
女 
來自
台中 
註冊時間
2012-6-20 
最後登錄
2019-5-24 
3#
發表於 2012-7-16 18:30 | 只看該作者
c_c_lai   大大謝謝幫忙 這程式對我來說還太難了.我只想用直線圖,在每一工作表最後儲存格Worksheets(wr).Range("A" & chart_sr & " :I" & chart_end)的範圍加入圖表,資料來源為同表格的
Worksheets(wr).   RANRE ("A" & z_sr & " :C" & xlRow),因為有10個工作表都要加入且每一個工作表最後空儲存格不一定所以列數用變數方式,工作表Worksheets(wr).   wr也是變數.因為我想用迴圈方式讓所有工作表一次完成,
ps  RANRE -> .RANGE 感謝提醒,確實粗心了

TOP

lamihsuen

帖子
33 
主題
4 
精華
0 
積分
37 
點名
0  
作業系統
w7 
軟體版本
pro 
閱讀權限
10 
性別
女 
來自
台中 
註冊時間
2012-6-20 
最後登錄
2019-5-24 
4#
發表於 2012-7-17 23:14 | 只看該作者
c_c_lai   大大回讀你的帖了看了GBKEE前輩的回覆其中下列的程式
03.    With ActiveSheet.ChartObjects(oShape.Name).Chart
改以用下列
With WORKSHEETS(WR).ChartObjects(1).Chart
就可以執行程式原來是物件的語法錯誤
08.    End With
感謝 兩位大哥的協助

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
5#
發表於 2012-7-18 07:28 | 只看該作者
回復 4# lamihsuen
沒錯，妳也可以應用下列 Set Sh = Sheets(xlSh) 以及  With Sh.ChartObjects.Add 的方式來處理：
  1. Private Sub 製圖程序(xlSh As String)                                '  重繪
  2.     Dim Sh As Worksheet, xi As Integer
  3.    
  4.     Set Sh = Sheets(xlSh)
  5.     Sh.ChartObjects.Delete

  7.     陣列設定 ShName:=Sh.Name
  8.     For xi = 1 To IIf(Sh.Name = "Omega", 5, 6)
  9.         With Sh.ChartObjects.Add(Sh.Cells(xRow(xi), yCol(xi)).Left, Sh.Cells(xRow(xi), yCol(xi)).Top, cWidth(xi), cHeight(xi)).Chart
  10.             .ChartType = IIf(xi >= 5, xlLine, xlColumnStacked)      ' xlLine-> 折線圖        ' xlColumnStacke-> 堆疊直條圖
  11.             .SetSourceData Source:=Chart_Source(xi)
  12.             .HasLegend = 0                                          ' 圖表的圖例:  不可見
  13.             .SeriesCollection(1).AxisGroup = IIf(xi >= 5, 2, 1)
  14.             
  15.             If (xi = 5) Then
  16.                 .SeriesCollection(4).ChartType = xlColumnClustered  ' 堆疊直條圖
  17.             ElseIf (xi = 6) Then
  18.                 .SeriesCollection(2).ChartType = xlColumnClustered  ' 堆疊直條圖
  19.             End If

  21.             With .Axes(xlCategory)                                  ' X座標軸
  22.                 .CategoryType = xlCategoryScale
  23.                 .TickLabels.NumberFormatLocal = "hh:mm"
  24.                 .MajorTickMark = xlNone
  25.                 .Border.Weight = xlHairline
  26.                 .Border.LineStyle = xlNone
  27.                 .TickLabelPosition = xlLow
  28.                 .TickLabels.Font.Size = 10
  29.             End With

  31.             '*******************************************************************
  32.             '  .
  33.             '  .
  34.             '  .

  36.         End With
  37.     Next xi
  38. End Sub
複製代碼
我再附上我實務應用上的真實圖表提供妳參考。無論是何種表單圖形，其設計理念幾乎是雷同的。

TOP

lamihsuen

帖子
33 
主題
4 
精華
0 
積分
37 
點名
0  
作業系統
w7 
軟體版本
pro 
閱讀權限
10 
性別
女 
來自
台中 
註冊時間
2012-6-20 
最後登錄
2019-5-24 
6#
發表於 2012-7-18 22:19 | 只看該作者
c_c_lai 大哥請問水平軸類別目前是在繪圖區內顯示我想跟你一樣顯示在繪圖區外下方如同你上方圖表的時間顯示一樣,因我的圖表資料數列有+值也有-值 因此我的目前是顯示在中間0的下方請問語法要如何表達.才能跟一樣顯示在繪圖區外下方謝謝指導

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
7#
發表於 2012-7-19 07:16 | 只看該作者
回復 6# lamihsuen
請附上你實際的檔案，我來看看你是如何設定。
P.S.  妳沒按 "回復" 鈕回復，如果我沒有留意到的話，是不知道有回復件的。

TOP

lamihsuen

帖子
33 
主題
4 
精華
0 
積分
37 
點名
0  
作業系統
w7 
軟體版本
pro 
閱讀權限
10 
性別
女 
來自
台中 
註冊時間
2012-6-20 
最後登錄
2019-5-24 
8#
發表於 2012-7-19 19:07 | 只看該作者
回復 7# c_c_lai
c-c-lai 大哥我上傳了檔案,但我不會把檔名貼到帖子內,不知你是否可從附件叫出,

實驗室能力分析測試工作 (修改中2).rar (191.59 KB)

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
9#
發表於 2012-7-20 16:43 | 只看該作者
回復 8# lamihsuen
請將原本 Module3 內的程式碼全部更換成以下之程式碼
  1. ' *********************************************************************
  2. '  Module3   (請將原本 Module3 內的程式碼全部更換成以下之程式碼)
  3. ' *********************************************************************
  4. Option Explicit

  6. Dim sPos(1 To 4)
  7. Dim xText As String
  8. Dim Chart_Source As Variant
  9. Dim StartKBarRow, EndKBarRow As Long

  11.    
  12. Public Sub 再分析結果()
  13.     Dim wr As Integer, an As Integer ' 設定COPY工作表數目計數器
  14.     Dim xlRow As Long
  15.             
  16.     ' wr = 4  目前預設從 c 到 sn， 總共有 12 個工作表單
  17.     For wr = 4 To Worksheets.Count
  18.         '  下次起始 列 起點
  19.         Dim angin_sr As Integer
  20.         Dim sr As Integer ' 定義第一次起始列數
  21.         sr = 6
  22.         an = 1
  23.         ' 計算"NG"的家數
  24.         Dim NGVALUE As Integer
  25.         NGVALUE = 0
  26.         ' 工作表從4 迴圈開始執行再分析結果到工作表的最後
  27.         Do Until Worksheets(wr).Cells((sr - 3), 12).Value = 0
  28.             ' outline 分析次數+1.並顯示在標題列(B4)儲存格
  29.             an = an + 1
  30.                   
  31.             ' angin_sr=再次分析起始列為:第一次起始列數+第一次家數+6格空格
  32.             angin_sr = sr + (Worksheets(wr).Cells((sr - 3), 1).Value + 6)
  33.                
  34.             ' 判別 上次分析有"NG"的去除,"OK"的COPY到本次表格
  35.             Dim again_oi, again_oj   As Integer ' 上次表格列,行數計數器
  36.             Dim again_ai, again_aj   As Integer ' 本次表格列,行數計數器
  37.                      
  38.             again_oi = sr
  39.             again_ai = angin_sr
  40.             ' 迴圈判別"ok"與"ng"從前次起始位置開始(sr)至前次表格最後(sr+前次表格"a"3的值
  41.             For again_oi = again_oi To sr + Worksheets(wr).Cells((sr - 3), 1).Value
  42.                 ' 如果值為"ok"該列copy 到本次表格.如果值為"ng"則不處理
  43.                 If Worksheets(wr).Cells(again_oi, 5).Value = "OK" Then
  44.                     With Worksheets(wr)
  45.                         .Cells(again_ai, 1).Value = .Cells(again_oi, 1).Value
  46.                         .Cells(again_ai, 2).Value = .Cells(again_oi, 2).Value
  47.                     End With
  48.                     again_ai = again_ai + 1
  49.                 End If
  50.             Next again_oi
  51.                   
  52.             ' 將前次第三列標題列標題copy 至本次表格第三列標題列標題
  53.             again_aj = 1
  54.             For again_oj = 1 To 12
  55.                 Worksheets(wr).Cells(angin_sr - 4, again_aj).Value = Worksheets(wr).Cells(sr - 4, again_oj).Value
  56.                 again_aj = again_aj + 1
  57.             Next again_oj
  58.                        
  59.             ' 利用變數求出本次表格最後列數目的用於求出第三列公式的最後範圍
  60.             xlRow = Worksheets(wr).Range("B" & angin_sr).End(xlDown).Row
  61.             With Worksheets(wr)
  62.                 ' 計算本次"A3"儲存格 NO.OF.RESULT值(分析值家數)從本次起始列至(angin_sr)至本次最後列數的數量
  63.                 .Cells(angin_sr - 3, 1).Formula = "=COUNT(B" & angin_sr & ":B" & xlRow & ")"
  64.                 ' 本次"B3"儲存格分析值中間值(MEDIAN)
  65.                 .Cells(angin_sr - 3, 2).Formula = "=MEDIAN(B" & angin_sr & ":B" & xlRow & ")"
  66.                 ' 本次C3儲存格IRQ植
  67.                 .Cells(angin_sr - 3, 3).Formula = "=(QUARTILE(B" & angin_sr & ":B" & xlRow & ",3) -QUARTILE(B" & angin_sr & ":B" & xlRow & ",1))*0.7413"
  68.                         
  69.                 ' 本次"E3"儲存格ROBUS CV值
  70.                 .Cells(angin_sr - 3, 5).Formula = "=  C3 / B3 *100"
  71.                 ' 本次"F3"儲存格分析值中最少值
  72.                 .Cells(angin_sr - 3, 6).Formula = "=MIN(B" & angin_sr & ":B" & xlRow & ")"
  73.                 ' 本次"G3"儲存格分析值中最大值
  74.                 .Cells(angin_sr - 3, 7).Formula = "=MAX(B" & angin_sr & ":B" & xlRow & ")"
  75.                 ' 本次"H3"儲存格RANGE值
  76.                 .Cells(angin_sr - 3, 8).Formula = "=G3-F3"
  77.                 ' 本次定義"I3"儲存格為E178值
  78.                 .Cells(angin_sr - 3, 9).Value = E178(.Cells(angin_sr - 3, 1).Value)
  79.                 ' 本次定義"j3"儲存格為分析值平均值
  80.                 .Cells(angin_sr - 3, 10).Formula = "=AVERAGE(B" & angin_sr & ":B" & xlRow & ")"
  81.                 ' 本次定義"k3"儲存格為stdv
  82.                 .Cells(angin_sr - 3, 11).Formula = "=STDEV(B" & angin_sr & ":B" & xlRow & ")"
  83.                 ' 本次"NG"家數 值
  84.                 .Cells(angin_sr - 3, 12).Value = NGVALUE
  85.                 ' 本次標題列"執行第"字串直接從前次儲存格位置copy
  86.                 .Cells(angin_sr - 2, 1).Value = .Cells(sr - 2, 1).Value
  87.                 ' 本次標題列顯示第an次分析
  88.                 .Cells(angin_sr - 2, 2).Value = an
  89.                 ' 本次標題列"ouline"字串直接從前次儲存格位置copy
  90.                 .Cells(angin_sr - 2, 3).Value = .Cells(sr - 2, 3).Value
  91.                 ' 本次定義實驗室編號標題列直接從前次儲存格位置copy
  92.                 .Cells(angin_sr - 1, 1).Value = .Cells(sr - 1, 1).Value
  93.                 ' 本次定義實驗室分析值標題列直接從前次儲存格位置copy
  94.                 .Cells(angin_sr - 1, 2).Value = .Cells(sr - 1, 2).Value
  95.                 ' 本次定義z-score值標題列直接從前次儲存格位置copy
  96.                 .Cells(angin_sr - 1, 3).Value = .Cells(sr - 1, 3).Value
  97.                 ' 本次定義outline標題列直接從前次儲存格位置copy
  98.                 .Cells(angin_sr - 1, 4).Value = .Cells(sr - 1, 4).Value
  99.                 ' 定義判定結果值標題列直接從前次儲存格位置copy
  100.                 .Cells(angin_sr - 1, 5).Value = .Cells(sr - 1, 5).Value
  101.                 ' 本次"C"欄 Z-SCORE 值計算
  102.                 .Range("C" & angin_sr & " :C" & xlRow).Formula = "=(b" & angin_sr & "-$B$" & angin_sr - 3 & ") /$C$" & angin_sr - 3
  103.                 ' 本次 "D"欄OUTLINE值計算
  104.                 .Range("d" & angin_sr & " :d" & xlRow).Formula = "= (B" & angin_sr & " -$J$" & angin_sr - 3 & ")/$K$" & angin_sr - 3
  105.                                       
  106.             End With
  107.                        
  108.             ' 本次"E' 欄判別OUTLINE,  true="ok"  FALSE="NG"
  109.             ' "NG"家數起始值 ,目的"將有"ng"家數記錄在"L3"欄位用於是否繼續判別OUTLINE
  110.                        
  111.             Worksheets(wr).Range("L" & angin_sr - 3).Value = 0
  112.                        
  113.             ' 開始判別從本次起始列開始
  114.             again_ai = angin_sr
  115.                           
  116.             For again_ai = again_ai To ((angin_sr) + Worksheets(wr).Range("A" & angin_sr - 3).Value - 1)
  117.                 ' 比對D6是否<   E178值(I3)欄
  118.                 If Worksheets(wr).Range("D" & again_ai).Value < Worksheets(wr).Range("I" & angin_sr - 3).Value Then
  119.                     ' 值=TRUE時E欄記錄""OK"
  120.                     Worksheets(wr).Range("E" & again_ai).Value = "OK"
  121.                 Else
  122.                     ' 值= FLACE時E欄記錄"NG"
  123.                     Worksheets(wr).Range("E" & again_ai).Value = "NG"
  124.                     ' 設"NG"FONT.COLOR為紅色
  125.                     Worksheets(wr).Range("E" & again_ai).Font.Color = vbRed
  126.                     ' "NG"家數+1
  127.                     Worksheets(wr).Range("L" & angin_sr - 3).Value = Worksheets(wr).Range("L" & angin_sr - 3).Value + 1
  128.                 End If
  129.             Next again_ai
  130.                                  
  131.             ' 如果還有"NG"值繼續執行OUTLINE
  132.             ' 將本次表格列數值設定給上次表格列數目的將本次表格列數作為下次表格計算基礎
  133.             sr = angin_sr
  134.         Loop
  135.                
  136.         ' ********此處為Worksheets(wr).Cells((sr - 3), 12).Value =0."NG" 家數=0 全部""可執行Z-SCORE
  137.         ' 定義z_sr為z_score起始表格列
  138.         Dim z_sr As Integer
  139.         angin_sr = sr ' 將sr值回愎給angin_sr目的為把最後一次outline "sr=angin_sr"回愎回來
  140.         sr = 6 ' 將sr回愎到第一次表格起始位置
  141.               
  142.         ' z_sr=執行z-score起始列為:最後一次起始列數+最後分析家數+6格空格
  143.         z_sr = angin_sr + (Worksheets(wr).Cells((angin_sr - 3), 1).Value + 6)
  144.               
  145.         ' 設定元素z_score標題列標題(z_score的第三列)
  146.         Worksheets(wr).Cells((z_sr - 2), 1).Value = "執行"
  147.         Worksheets(wr).Cells((z_sr - 2), 2).Value = Worksheets(wr).Name
  148.         Worksheets(wr).Cells((z_sr - 2), 3).Value = "z_score"
  149.                   
  150.         ' 將第一次表格"實驗室編號"(第一行號)與"分析值"(第二行)copy至z_score表格因為要全部"實驗室編號"與"分析值"
  151.                     
  152.         Dim z_oi, z_oj   As Integer    ' 第一次表格列,行數計數器
  153.         Dim z_ai, z_aj   As Integer    ' z-score表格列,行數計數器
  154.         z_oi = sr                      ' z_oi定義為第一次起始格表格開始計數
  155.         z_ai = z_sr                    ' z_ai定義為z_score起始表格開始計數
  156.                  
  157.         For z_oi = z_oi To sr + Worksheets(wr).Cells((sr - 3), 1).Value
  158.             With Worksheets(wr)
  159.                 .Cells(z_ai, 1).Value = .Cells(z_oi, 1).Value
  160.                 .Cells(z_ai, 2).Value = .Cells(z_oi, 2).Value
  161.             End With
  162.             z_ai = z_ai + 1
  163.         Next z_oi      
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
10#
發表於 2012-7-20 16:44 | 只看該作者
本帖最後由 c_c_lai 於 2012-7-20 16:46 編輯

回復 8# lamihsuen
因程式碼大於規定大小，故將下半段再次貼上。
  1.         ' 將最後一次第一列(公式)標題列標題與第二列公式值copy 至ZSCORE表格第一列與第二列
  2.         z_oi = angin_sr
  3.         z_ai = z_sr
  4.         z_aj = 1
  5.         For z_oj = 1 To 12
  6.             Worksheets(wr).Cells(z_ai - 4, z_aj).Value = Worksheets(wr).Cells(z_oi - 4, z_oj).Value
  7.             Worksheets(wr).Cells(z_ai - 3, z_aj).Value = Worksheets(wr).Cells(z_oi - 3, z_oj).Value
  8.             z_aj = z_aj + 1
  9.         Next z_oj
  10.         ' 定義第四列表格標題列
  11.         xlRow = Worksheets(wr).Range("B" & z_sr).End(xlDown).Row
  12.         With Worksheets(wr)
  13.             .Cells((z_sr - 1), 1).Value = .Cells((sr - 1), 1).Value
  14.             .Cells((z_sr - 1), 2).Value = .Cells((sr - 1), 2).Value
  15.             .Cells((z_sr - 1), 3).Value = .Cells((sr - 1), 3).Value
  16.             .Cells((z_sr - 1), 4).Value = "判別結果"
  17.             .Cells((z_sr - 1), 5).Value = "分析方法"
  18.             .Cells((z_sr - 1), 6).Value = "使用儀器"
  19.                                                          
  20.             ' 本次"C"欄 Z-SCORE 值計算
  21.             .Range("C" & z_sr & " :C" & xlRow).Formula = "=(b" & z_sr & "-$B$" & z_sr - 3 & ") /$C$" & z_sr - 3
  22.             .Range("D" & z_sr & " :D" & xlRow).Formula = "=IF(C" & z_sr & ">=3,""異常"",IF( C" & z_sr & "<=2,""ok"",""有質疑""))"
  23.         End With
  24.         '  定義z值判別結果並顯示(D)欄,"(Z)值<=2為"OK"顯示綠色","2<(Z)值<3為"有質疑"顯示黃色,(Z)值>3為"異常"顯示紅色
  25.                                        
  26.         '  繪製統計分析圖表
  27.         Call DrawStatistics(wr)
  28.     Next wr
  29. End Sub

  31. Sub DrawStatistics(ct As Integer)
  32.     Dim tbl As String

  34.     StartKBarRow = 6
  35.     With Worksheets(ct)
  36.         tbl = .Name
  37.         EndKBarRow = .Range("A1").CurrentRegion.Rows.Count
  38.         Set Chart_Source = Range(tbl & "!$C$" & CStr(StartKBarRow) & ":" & tbl & "!$C$" & CStr(EndKBarRow))
  39.         sPos(1) = CInt(Mid("205*090*090*100*132*096*132*090*173*090*314*090", (ct - 4) * 4 + 1, 3))
  40.         sPos(2) = CInt(Mid("001*001*001*001*001*001*001*001*001*001*001*001", (ct - 4) * 4 + 1, 3))
  41.         sPos(3) = CInt(Mid("720*720*720*720*720*720*720*720*720*720*720*720", (ct - 4) * 4 + 1, 3))
  42.         sPos(4) = CInt(Mid("320*320*320*320*320*320*320*320*320*320*320*320", (ct - 4) * 4 + 1, 3))
  43.         xText = UCase(tbl) & " : Z - Score"
  44.         製圖程序 xlSh:=tbl
  45.     End With
  46. End Sub

  48. Private Sub 製圖程序(xlSh As String)                                ' 全部重繪
  49.     Dim Sh As Worksheet, xi As Integer
  50.    
  51.     Set Sh = Sheets(xlSh)
  52.     Sh.ChartObjects.Delete

  54.     With Sh.ChartObjects.Add(Sh.Cells(sPos(1), sPos(2)).Left, Sh.Cells(sPos(1), sPos(2)).Top, sPos(3), sPos(4)).Chart
  55.         .ChartType = xlColumnClustered    ' xlColumnStacked                            ' xlColumnStacke-> 堆疊直條圖
  56.         .SetSourceData Source:=Chart_Source
  57.         .HasLegend = 0                                          ' 圖表的圖例:  不可見
  58.         .SeriesCollection(1).AxisGroup = 1
  59.             
  60.         With .Axes(xlCategory)                                  ' X座標軸
  61.             .CategoryType = xlCategoryScale
  62.             ' .TickLabels.NumberFormatLocal = "hh:mm"
  63.             .MajorTickMark = xlNone
  64.             .Border.Weight = xlHairline
  65.             .Border.LineStyle = xlNone
  66.             .TickLabelPosition = xlLow
  67.             .TickLabels.Font.Size = 10
  68.         End With
  69.                   
  70.             '*******************************************************************
  71.                   
  72.         With .SeriesCollection(1)
  73.             .Shadow = False                                ' 圖表中的數列(1)
  74.             .InvertIfNegative = True
  75.             ' .InvertColor = RGB(255, 124, 128)                      ' 當表列數值為負值時，將其顯示之顏色更變成淺天藍色
  76.             .InvertColor = RGB(32, 178, 208)                         ' 當表列數值為負值時，將其顯示之顏色更變成青藍色
  77.         
  78.             With .Format.Fill
  79.                 .Visible = msoTrue
  80.                 ' .ForeColor.RGB = RGB(149, 179, 215)                ' 當表列數值為正值時，顯示之顏色為橘紅色
  81.                 .ForeColor.RGB = RGB(255, 69, 0)                     ' 當表列數值為正值時，顯示之顏色為粉紅色
  82.                 .Transparency = 0
  83.                 .Solid
  84.             End With
  85.         
  86.             With .Border
  87.                 .Weight = xlHairline
  88.                 .LineStyle = xlNone
  89.             End With
  90.         
  91.             ' With .Interior
  92.             '     .ColorIndex = 5
  93.             '     .PatternColorIndex = 42
  94.             '     .Pattern = xlSolid
  95.             ' End With
  96.         End With
  97.                   
  98.         ' *******************************************************************
  99.                      
  100.         With .Axes(xlValue).TickLabels.Font                    ' Y座標軸上刻度的刻度標籤的字體
  101.             .FontStyle = "標準"
  102.             .Size = 10
  103.         End With
  104.                      
  105.         With .Axes(xlValue)
  106.             .MajorUnit = 2                                     ' 圖表左側數列之間距值設定
  107.             ' .MaximumScale = 30
  108.             ' .MinimumScale = -40
  109.         End With
  110.         
  111.         .HasTitle = True                                       ' 圖表的標題   可見
  112.               
  113.         With .ChartTitle                                       ' 圖表的標題
  114.             .Top = 1
  115.             .Text = xText
  116.             .Font.Size = 16
  117.         End With

  119.         With .PlotArea                                         ' 圖表的繪圖區
  120.             .Top = 16
  121.             .Left = 1
  122.             .Width = sPos(3)
  123.             .Height = sPos(4)
  124.             .Interior.ColorIndex = xlNone
  125.         End With
  126.     End With
  127. End Sub
複製代碼
應該滿足妳的要求了吧！

TOP

        靜思自在 : 一句溫暖的話，就像往別人身上灑香水，自己會沾到兩三滴。
1234
返回列表 上一主題