123
返回列表 上一主題 發帖

[發問] 如何使用VBA或函數做多個陣列數值的比較及格式化條件的設定

cmo140497

帖子
95 
主題
29 
精華
0 
積分
150 
點名
0  
作業系統
windows2003 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
來自
Kaoshiung 
註冊時間
2010-11-5 
最後登錄
2018-2-8 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-12-16 22:09 | 只看該作者

[發問] 如何使用VBA或函數做多個陣列數值的比較及格式化條件的設定

本帖最後由 GBKEE 於 2012-12-17 15:51 編輯

Dear 各位版主或高手大大們 :
  小弟先前請教過各位版主及大大的一些巨集的問題,也感謝各位的不吝指教,今有一個問題,已經煩了快一個月,已遍歷國外各大網站vba或函數的例子,仍無法解決困擾已久的問題
希望可以從各位版主或高手大大們尋得協助,謝謝!
以下介紹幾個網站還滿不錯的:
http://www.get-digital-help.com/category/excel/table/
http://chandoo.org/wp/2009/03/25/using-array-formulas-example1/
http://www.contextures.com/tiptech.html

小弟想依指定路徑下之資料夾找到資料夾內之檔案,作自動新增核取方塊數量,如以下圖片有3個文字檔內容已被小弟載入excel內,要如何比較各筆之相同位址之資料,是否重覆?如有
重覆並計算重覆次數除以核定片數,作百分比之格式化條件的顏色分類,如下圖所示



尋找各組數相同位之是否重覆或獨立之數值作百分比格式化條件.zip (13.93 KB)
收藏 分享

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
270  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-11-4 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2012-12-16 23:47 | 只看該作者
回復 1# cmo140497
試試看
  1. Sub AddCheckBox() '加入核取方塊
  2. '因為沒有提供文字檔，以現有Item作為新增條件
  3. With Sheet1
  4. .CheckBoxes.Delete
  5. k = Application.CountIf(.Columns("E"), "ID")
  6. Set A = .Columns("F").Find("Item", lookat:=xlPart)
  7. For i = 1 To k
  8.   With .CheckBoxes.Add(.Cells(i + 4, "C").Left, .Cells(i + 4, "C").Top, .Cells(i + 4, "C").Width, .Cells(i + 4, "C").Height)
  9.      .Characters.Text = A
  10.   End With
  11.   Set A = .Columns("F").FindNext(A)
  12. Next
  13. End With
  14. End Sub
  15. Sub 比對()
  16. Dim Sp As Shape, Rng As Range, A As Range, MyRng As Range
  17. With Sheet1
  18.    For Each Sp In .Shapes
  19.      If Sp.Name Like "Check Box*" Then
  20.      Set A = .Columns("F").Find(Sp.OLEFormat.Object.Caption)
  21.       If Sp.OLEFormat.Object.Value = 1 Then
  22.       If Rng Is Nothing Then
  23.          Set Rng = A.Offset(1, 0).Resize(5, 5)
  24.          Else
  25.          Set Rng = Union(Rng, A.Offset(1, 0).Resize(5, 5))
  26.        End If
  27.        End If
  28.      End If
  29.     Next
  30.     Set MyRng = .[M3:Q7]
  31. If Not Rng Is Nothing Then
  32.   For i = 1 To 5
  33.      For j = 1 To 5
  34.      If MyRng(i, j) <> 0 And MyRng(i, j) <> "___" Then
  35.        For Each ar In Rng.Areas
  36.          If ar(i, j) = MyRng(i, j) Then p = p + 1
  37.        Next
  38.        s = p / Rng.Areas.Count: p = 0
  39.        n = Application.Lookup(s, Array(0, 0.1, 0.2, 0.4, 0.6, 0.8, 1), Array(1, 2, 3, 4, 5, 6, 7))
  40.        MyRng.Cells(i, j).Interior.ColorIndex = .[S2:Y2].Cells(1, n).Interior.ColorIndex
  41.        Else
  42.        MyRng.Cells(i, j).Interior.ColorIndex = -4142
  43.     End If
  44.      Next
  45.   Next
  46. End If
  47. End With
  48. End Sub
複製代碼
學海無涯_不恥下問

TOP

cmo140497

帖子
95 
主題
29 
精華
0 
積分
150 
點名
0  
作業系統
windows2003 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
來自
Kaoshiung 
註冊時間
2010-11-5 
最後登錄
2018-2-8 
3#
發表於 2012-12-17 09:12 | 只看該作者
回復 2# Hsieh


    實在大大的感謝Hsieh 超級版主的頂力協助,請問版主您大概寫這個程式花了多少時間,小弟昨晚po的,才剛上班打開電腦就收到回覆了,實在令小弟有點....:'(

另還有一個問題想請教版主,關於底下這行,這陣列是小弟自己用算的,請問要如何自行做陣列之運算(比較/合併),將有重覆或獨立值代至新的陣列內,仍繼續做條件格式化百分比,
Set MyRng = .[M3:Q7]
因為這陣列有可能x/y會有20~50之多,如果可以自行比較出結果的話.....再度感謝版主不辭辛苦的解決新手小弟的困擾,實在感恩!

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
270  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-11-4 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 2012-12-17 09:19 | 只看該作者
回復  Hsieh


    實在大大的感謝Hsieh 超級版主的頂力協助,請問版主您大概寫這個程式花了多少時間,小 ...
cmo140497 發表於 2012-12-17 09:12


用多少時間並不重要，是否達到需求才是重點
至於MyRng是要比對改變顏色的區域
至於你要多個範圍就看你的表格分佈規則而定
上傳檔案試試看吧
學海無涯_不恥下問

TOP

cmo140497

帖子
95 
主題
29 
精華
0 
積分
150 
點名
0  
作業系統
windows2003 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
來自
Kaoshiung 
註冊時間
2010-11-5 
最後登錄
2018-2-8 
5#
發表於 2012-12-17 09:31 | 只看該作者
回復 2# Hsieh


    不好意思,版主再度打擾您,剛才忘記附上文字檔.
如果各陣列位址的值均不相同,則視為100%,代碼7的顏色,不知是否可行,感謝您。


test-g2.zip (800 Bytes)

TOP

cmo140497

帖子
95 
主題
29 
精華
0 
積分
150 
點名
0  
作業系統
windows2003 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
來自
Kaoshiung 
註冊時間
2010-11-5 
最後登錄
2018-2-8 
6#
發表於 2012-12-17 09:47 | 只看該作者
回復 4# Hsieh


    不好意思,小弟沒來得及看回覆,又丟了疑問給您,實在抱歉.
小弟的陣列均為二維,行列數有時可能會多達20更甚多,內容只有固定之數值F00~F150,沒有其它數值或文字,只是陣列數須依實際檔案數而定,要篩選或比對則由人自行決定,
資料附檔如下附件,請參考,再度感謝,謝謝!

尋找各組數相同位之是否重覆或獨立之數值作百分比格式化條件.zip (31.73 KB)

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
270  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-11-4 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
7#
發表於 2012-12-17 10:32 | 只看該作者
回復 6# cmo140497


   這樣已經錯亂了，請說明你的整體流程
所附的txt檔案是要寫入E:J欄位或是要放到M:Q欄作為比對變色儲存格?
這些文字檔資料所形成的陣列欄、列數可能是不同的，那麼顏色對照表[S2:Y2]的位置是否又要改變?
學海無涯_不恥下問

TOP

cmo140497

帖子
95 
主題
29 
精華
0 
積分
150 
點名
0  
作業系統
windows2003 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
來自
Kaoshiung 
註冊時間
2010-11-5 
最後登錄
2018-2-8 
8#
發表於 2012-12-17 13:34 | 只看該作者
回復 7# Hsieh

不好意思,小弟再整理一下流程,再麻煩版主您再幫小弟看一下,再度打擾您了,謝謝!

   


test3.zip (33.77 KB)

尋找各組數相同位之是否重覆或獨立之數值作百分比格式化條件_3.zip (33.88 KB)

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
9#
發表於 2012-12-17 15:42 | 只看該作者
回復 8# cmo140497
AUTO_OPEN() 檔案開啟時自動執行
  1. Option Explicit
  2. Sub AUTO_OPEN() '加入核取方塊'因為沒有提供文字檔，以現有Item作為新增條件
  3.     Dim A As Range, K As Integer, i As Integer
  4.     With Sheet1
  5.         .CheckBoxes.Delete
  6.         .Range("B:Z").Interior.ColorIndex = xlNone
  7.         K = Application.CountIf(.Columns("A"), "ID")
  8.         Set A = .Columns("A").Find("ID", lookat:=xlPart)
  9.         For i = 1 To K
  10.         Cells(i + 5, "AA").Select
  11.             With .CheckBoxes.Add(.Cells(i + 5, "AA").Left, .Cells(i + 5, "AA").Top, .Cells(i + 5, "AA").Width, .Cells(i + 5, "AA").Height)
  12.                 .Characters.Text = "Item" & i
  13.                 .Name = "Item" & i
  14.                 .OnAction = "EX"                              'CheckBoxes 指巨集的 程式
  15.             End With
  16.             A.Offset(1, 1).Resize(24, 24).Name = "_Item" & i  '資料範圍設立名稱:如工作表定義名稱
  17.             Set A = .Columns("A").FindNext(A)
  18.         Next
  19.         '**  製定百分比 為 7 等分 [S1:Y1] 百分比由大到小   ***
  20.         For i = 1 To 7  '百分比由大到小   
  21.             .[AA2].Cells(1, i) = 1 + (1 / 7) - (i / 7)
  22.         Next
  23.     End With
  24. End Sub
  25. Sub EX()   '已執行AUTO_OPEN, 按選CheckBoxes的程式
  26.     Dim Rng(0 To 25) As Range, S, i
  27.     Dim P As Integer, B As CheckBox, E As Variant
  28.     With Sheet1
  29.          .Range("B:Z").Interior.ColorIndex = xlNone
  30.         For Each B In .CheckBoxes
  31.             If B = 1 Then                                               'CheckBoxe；勾選 = 1
  32.                 P = P + 1
  33.                 If Not Rng(0) Is Nothing Then
  34.                     Set Rng(0) = Union(Rng(0), .Range("_" & B.Name))
  35.                     For i = 1 To 24                                     '已勾選範圍之 第1欄-第24欄
  36.                         For Each E In Rng(0).Areas
  37.                             Set Rng(i) = Union(E.Columns(i), Rng(i))    '同一欄位 設為同一範圍
  38.                         Next
  39.                     Next
  40.                 Else
  41.                     Set Rng(0) = .Range("_" & B.Name)
  42.                     For i = 1 To 24
  43.                         Set Rng(i) = Rng(0).Columns(i)
  44.                     Next
  45.                 End If
  46.             End If
  47.         Next
  48.         If P = 0 Then Exit Sub
  49.         Application.ScreenUpdating = False
  50.         For i = 1 To 24                                     '範圍有24欄
  51.             .Columns(Columns.Count - 1) = ""                '清除 最後第2欄資料
  52.             .Columns(Columns.Count) = ""                    '清除 最後1欄資料
  53.             Rng(i).Copy Cells(1, Columns.Count)             '複製欄的資料
  54.             .Columns(Columns.Count).AdvancedFilter xlFilterCopy, .Cells(1, Columns.Count - 1), Unique:=True
  55.             '進階篩選:選取不重複的資料,減少迴圈.
  56.             .Columns(Columns.Count - 1).Sort Key1:=.Cells(1, Columns.Count - 1), Order1:=xlDescending, Header:=xlNo
  57.             '排序 : 不要的資料置於底部
  58.             Set Rng(25) = .Columns(Columns.Count - 1).Cells(1)   '設定要尋找的字串
  59.             
  60.             With Rng(i)
  61.                 Do Until Rng(25) = "___" Or Rng(25) = "0" Or Rng(25) = ""
  62.                     Set Rng(0) = .Find(Rng(25), lookat:=xlWhole)
  63.                     If Not Rng(0) Is Nothing Then
  64.                         .Replace Rng(25), "=xxx", xlWhole               '如同工作表尋找:全部取代 為錯誤的公式
  65.                         .SpecialCells(xlCellTypeFormulas).Select
  66.                         S = Application.CountA(Selection) / P
  67.                        If S <= 1 Then
  68.                             S = Application.Match(S, [AA2:AG2], -1)     'Match 的排序:大到小
  69.                         Else
  70.                             S = 1
  71.                        End If
  72.                         Selection.Value = Rng(25)                       '復原 取代的字串
  73.                         Selection.Interior.ColorIndex = Sheet1.[AA2].Cells(1, S).Interior.ColorIndex
  74.                     End If
  75.                 Set Rng(25) = Rng(25).Offset(1)                         '尋找下一個字串
  76.                 Loop
  77.             End With
  78.         Next
  79.         .Columns(Columns.Count - 1) = ""                '清除 最後第2欄資料
  80.         .Columns(Columns.Count) = ""                    '清除 最後1欄資料
  81.         Application.ScreenUpdating = True
  82.         .CheckBoxes(Application.Caller).TopLeftCell.Select
  83.       End With
  84. End Sub
複製代碼

TOP

cmo140497

帖子
95 
主題
29 
精華
0 
積分
150 
點名
0  
作業系統
windows2003 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
來自
Kaoshiung 
註冊時間
2010-11-5 
最後登錄
2018-2-8 
10#
發表於 2012-12-17 16:18 | 只看該作者
回復 9# GBKEE


    再度感謝版主幫小弟解決這個困擾已久的問題,不過小弟在試run的時候,出現了一個問題,如下圖示所示,實在不知道如何作troubleshooting,再麻煩版主一下,感恩

TOP

        靜思自在 : 世上有兩件事不能等：一、孝順 二、行善。
123
返回列表 上一主題