返回列表 上一主題 發帖

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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2012-12-17 16:36 | 顯示全部帖子
本帖最後由 GBKEE 於 2012-12-17 16:45 編輯

回復 10# cmo140497
你的資料顯示是2003版 何不在2003試看
測試12# 2010版 需是
  1. .Columns(Columns.Count).AdvancedFilter xlFilterCopy, , .Cells(1, Columns.Count - 1), Unique:=True
複製代碼

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2012-12-20 09:34 | 顯示全部帖子
本帖最後由 GBKEE 於 2012-12-20 09:44 編輯

16# 檔案的程式碼,試看看程式處裡的速度是否滿意!!
  1. Option Explicit
  2. Const xRow As Integer = 24
  3. Const xCol As Integer = 24
  4. Private Sub AUTO_OPEN()
  5.     Dim Rng As Range, E As Range, xi As Integer
  6.     Sheets("Overlap").Activate
  7.     Set Rng = [A:A]
  8.     Rng.Replace "ID", "=XXX", xlWhole
  9.     Set Rng = Rng.SpecialCells(xlCellTypeFormulas, xlErrors)
  10.     ActiveSheet.CheckBoxes.Delete
  11.     For Each E In Rng.Cells
  12.         With Cells(xi + 5, "AA")
  13.             With ActiveSheet.CheckBoxes.Add(.Left, .Top, .Width, .Height)
  14.                 .Caption = "Item" & xi + 1
  15.                 .OnAction = "Ex_Action"
  16.                 E.Offset(1, 1).Resize(xRow, xCol).Name = "_" & .Caption  '設置範圍名稱
  17.             End With
  18.         End With
  19.         xi = xi + 1
  20.     Next
  21.     Rng.Value = "ID"
  22. End Sub
  23. Private Sub Ex_Action()
  24.     Dim cBox As Object, Rng As Range, r As Integer, y As Integer, xi As Integer
  25.     Dim Ar(), E As Variant, t As Date
  26.     t = Time
  27.     For Each cBox In ActiveSheet.CheckBoxes
  28.         If cBox.Value = 1 Then
  29.             If Rng Is Nothing Then Set Rng = Range("_" & cBox.Caption)
  30.             If Not Rng Is Nothing Then Set Rng = Union(Rng, Range("_" & cBox.Caption))
  31.         End If
  32.     Next
  33.     With Range("AI5").Resize(xRow, xCol)
  34.         .Interior.ColorIndex = xlNone
  35.         For Each cBox In .Cells
  36.             If cBox <> "___" Then cBox = 0
  37.         Next
  38.     End With
  39.     Application.ScreenUpdating = False
  40.     Range("B:Z").Interior.ColorIndex = xlNone
  41.     If Rng Is Nothing Then Exit Sub
  42.     ReDim Ar(1 To xRow, 1 To xCol)                                      '設定:陣列大小
  43.     '********  每一個範圍中同一位置有資料的:計數
  44.     For Each cBox In Rng.Areas                                          '處裡每一個範圍
  45.         For r = 1 To xRow
  46.             For y = 1 To xCol
  47.                 If cBox(r, y) = "___" Then GoTo 0                       '不處裡
  48.                 If cBox(r, y) <> 0 Then Ar(r, y) = Ar(r, y) + 1         '紀錄資料
  49. 0:
  50.             Next
  51.         Next
  52.     Next
  53.     '********  每一個範圍中同一位置資料的計數百分比:設下顏色
  54.     For Each cBox In Rng.Areas
  55.         For r = 1 To xRow
  56.             For y = 1 To xCol
  57.                 xi = 0                                                  '百分比:歸零
  58.                 If cBox(r, y) = "___" Then GoTo 1
  59.                 For Each E In Array(0, 0.19, 0.39, 0.59, 0.79, 0.99, 1)
  60.                     xi = xi + 1
  61.                     If Ar(r, y) / Rng.Areas.Count <= E Then Exit For    '取得百分比
  62.                 Next
  63.                 If Ar(r, y) > 0 Then cBox(r, y).Interior.ColorIndex = [AA2].Cells(1, xi).Interior.ColorIndex
  64.                                                                         '[AA2].Cells(1, xi):顏色的位置
  65. 1:
  66.             Next
  67.         Next
  68.     Next
  69.     '********  統計範圍位置資料: 計數, 百分比顏色
  70.     With Range("AI5")
  71.         For r = 1 To xRow
  72.             For y = 1 To xCol
  73.                 If .Cells(r, y) <> "___" Then
  74.                     .Cells(r, y) = IIf(Ar(r, y) = "", 0, Ar(r, y))
  75.                     If Ar(r, y) > 0 Then
  76.                     .Cells(r, y).Interior.ColorIndex = Rng(r, y).Interior.ColorIndex
  77.                     Else
  78.                     .Cells(r, y).Interior.ColorIndex = [AA2].Interior.ColorIndex
  79.                     End If
  80.                 End If
  81.             Next
  82.         Next
  83.     End With
  84.     Application.ScreenUpdating = True
  85.     MsgBox Format(t, "開始 hh:mm:ss") & vbLf & Format(Time, "結束 hh:mm:ss") & vbLf & vbLf & Format(Time - t, "費時 hh:mm:ss")
  86. End Sub
複製代碼
回復 19# cmo140497

TOP

        靜思自在 : 對父母要知恩，感恩、報恩。
返回列表 上一主題