如何使用VBA或函數做多個陣列數值的比較及格式化條件的設定 - Excel程式區

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

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

21^# 跳轉到 »

發表於 2012-12-19 23:33 | 只看該作者

回復 19# cmo140497

Sub Get_Rng()
Dim A As Range, Rng As Range, Sp As Shape, CRng As Range
With ActiveSheet
For Each Sp In .Shapes
If Sp.Name Like "Check Box*" Then
If Sp.OLEFormat.Object.Value = 1 Then
n = Sp.OLEFormat.Object.Caption
Set A = .Columns("E").Find(n, lookat:=xlWhole)
If Rng Is Nothing Then
Set Rng = A.CurrentRegion
Else
Set Rng = Union(Rng, A.CurrentRegion)
End If
End If
End If
Next
If Rng Is Nothing Then
MsgBox "Nothing"
Else
For x = 1 To Rng.Areas(1).Columns.Count
For y = 2 To Rng.Areas(1).Rows.Count
ReDim ay(1 To Rng.Areas.Count)
ReDim ary(1 To Rng.Areas.Count)
For i = 1 To Rng.Areas.Count
ay(i) = Rng.Areas(i).Cells(y, x)
If Rng.Areas(i).Cells(y, x) = "000" Then zero = zero + 1
Next
For j = 1 To UBound(ay)
For s = 1 To UBound(ay)
If ay(j) = ay(s) Then cnt = cnt + 1
Next
ary(j) = cnt: cnt = 0
Next
g = Application.Lookup(Application.Max(ary) / Rng.Areas.Count, Array(0, 0.19, 0.39, 0.59, 0.79, 0.99, 1), Array(4, 44, 8, 6, 7, 3, 16))
With .[AI2].CurrentRegion.Cells(y - 1, x)
If .Value = "___" Then
.Interior.ColorIndex = -4142
ElseIf zero = Rng.Areas.Count Then '全部都是000
.Interior.ColorIndex = 4
Else
.Interior.ColorIndex = g
End If
zero = 0
End With
10
Next
Next
End If
End With
End Sub

複製代碼

學海無涯_不恥下問

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兔年全勤獎章

22^#

發表於 2012-12-20 09:34 | 只看該作者

本帖最後由 GBKEE 於 2012-12-20 09:44 編輯

16# 檔案的程式碼,試看看程式處裡的速度是否滿意!!

Option Explicit
Const xRow As Integer = 24
Const xCol As Integer = 24
Private Sub AUTO_OPEN()
Dim Rng As Range, E As Range, xi As Integer
Sheets("Overlap").Activate
Set Rng = [A:A]
Rng.Replace "ID", "=XXX", xlWhole
Set Rng = Rng.SpecialCells(xlCellTypeFormulas, xlErrors)
ActiveSheet.CheckBoxes.Delete
For Each E In Rng.Cells
With Cells(xi + 5, "AA")
With ActiveSheet.CheckBoxes.Add(.Left, .Top, .Width, .Height)
.Caption = "Item" & xi + 1
.OnAction = "Ex_Action"
E.Offset(1, 1).Resize(xRow, xCol).Name = "_" & .Caption '設置範圍名稱
End With
End With
xi = xi + 1
Next
Rng.Value = "ID"
End Sub
Private Sub Ex_Action()
Dim cBox As Object, Rng As Range, r As Integer, y As Integer, xi As Integer
Dim Ar(), E As Variant, t As Date
t = Time
For Each cBox In ActiveSheet.CheckBoxes
If cBox.Value = 1 Then
If Rng Is Nothing Then Set Rng = Range("_" & cBox.Caption)
If Not Rng Is Nothing Then Set Rng = Union(Rng, Range("_" & cBox.Caption))
End If
Next
With Range("AI5").Resize(xRow, xCol)
.Interior.ColorIndex = xlNone
For Each cBox In .Cells
If cBox <> "___" Then cBox = 0
Next
End With
Application.ScreenUpdating = False
Range("B:Z").Interior.ColorIndex = xlNone
If Rng Is Nothing Then Exit Sub
ReDim Ar(1 To xRow, 1 To xCol) '設定:陣列大小
'******** 每一個範圍中同一位置有資料的:計數
For Each cBox In Rng.Areas '處裡每一個範圍
For r = 1 To xRow
For y = 1 To xCol
If cBox(r, y) = "___" Then GoTo 0 '不處裡
If cBox(r, y) <> 0 Then Ar(r, y) = Ar(r, y) + 1 '紀錄資料
0:
Next
Next
Next
'******** 每一個範圍中同一位置資料的計數百分比:設下顏色
For Each cBox In Rng.Areas
For r = 1 To xRow
For y = 1 To xCol
xi = 0 '百分比:歸零
If cBox(r, y) = "___" Then GoTo 1
For Each E In Array(0, 0.19, 0.39, 0.59, 0.79, 0.99, 1)
xi = xi + 1
If Ar(r, y) / Rng.Areas.Count <= E Then Exit For '取得百分比
Next
If Ar(r, y) > 0 Then cBox(r, y).Interior.ColorIndex = [AA2].Cells(1, xi).Interior.ColorIndex
'[AA2].Cells(1, xi):顏色的位置
1:
Next
Next
Next
'******** 統計範圍位置資料: 計數, 百分比顏色
With Range("AI5")
For r = 1 To xRow
For y = 1 To xCol
If .Cells(r, y) <> "___" Then
.Cells(r, y) = IIf(Ar(r, y) = "", 0, Ar(r, y))
If Ar(r, y) > 0 Then
.Cells(r, y).Interior.ColorIndex = Rng(r, y).Interior.ColorIndex
Else
.Cells(r, y).Interior.ColorIndex = [AA2].Interior.ColorIndex
End If
End If
Next
Next
End With
Application.ScreenUpdating = True
MsgBox Format(t, "開始 hh:mm:ss") & vbLf & Format(Time, "結束 hh:mm:ss") & vbLf & vbLf & Format(Time - t, "費時 hh:mm:ss")
End Sub