- 帖子
- 163
- 主題
- 1
- 精華
- 0
- 積分
- 170
- 點名
- 0
- 作業系統
- Window 7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2010-9-5
- 最後登錄
- 2022-7-20
|
本帖最後由 Kubi 於 2016-4-10 21:11 編輯
另外提供幾種色彩標示法做參考：
一、先[給值](產生新樣本)，以方便做測試
二、利用[輔助欄排序法]來填色
三、利用[輔助欄非排序法]來填色
四、利用[陣列法]來填色
五、[排序]是作為填色後，方便資料驗證之用
六、如用字點檔(Dictionary)來填色也可盡功，請自行撰寫
底下就式程式碼拙作：
Option Base 1
Sub 給值()
Randomize
Cells.Interior.ColorIndex = xlNone
Cells.ClearContents
er = Int(Rnd * 100) + 10
Application.ScreenUpdating = False
For c = 1 To Int(Rnd * 10) + 2
For r = 1 To er
Cells(r, c).Value = Int(Rnd * 1000)
Next r
Next c
Application.ScreenUpdating = True
End Sub
Sub 輔助欄排序法()
ci = Array(3, 8, 6)
er = [A1].CurrentRegion.Rows.Count
ec = [A1].CurrentRegion.Columns.Count + 1
Application.ScreenUpdating = False
For i = 1 To er
Cells(i, ec).Value = i
Next i
For c = 1 To ec - 1
Range(Cells(1, c), Cells(er, ec)).Sort key1:=Cells(1, c), order1:=2
x = -1
n = -1
For Each cell In Cells(1, c).Resize(er)
If cell.Value <> n Then
n = cell.Value
x = x + 1
If x = 3 Then Exit For
cell.Interior.ColorIndex = ci(x + 1)
Else
cell.Interior.ColorIndex = ci(x + 1)
End If
Next cell
Range(Cells(1, c), Cells(er, ec)).Sort key1:=Cells(1, ec), order1:=1
Next c
Columns(ec).ClearContents
Application.ScreenUpdating = True
End Sub
Sub 輔助欄非排序法()
ci = Array(3, 8, 6)
er = [A1].CurrentRegion.Rows.Count
ec = [A1].CurrentRegion.Columns.Count
Application.ScreenUpdating = False
For c = 1 To ec
Range(Cells(1, ec + 1), Cells(er, ec + 2)).ClearContents
For r = 1 To er
For i = 1 To 3
If Cells(i, ec + 1).Value = "" Then
Cells(i, ec + 1).Value = Cells(r, c).Value
Cells(i, ec + 2).Value = Trim(r)
Exit For
Else
If Cells(r, c).Value = Cells(i, ec + 1).Value Then
Cells(i, ec + 2).Value = Cells(i, ec + 2).Value & "," & Trim(r)
Exit For
Else
If Cells(r, c).Value > Cells(i, ec + 1).Value Then
Range(Cells(i, ec + 1), Cells(i, ec + 2)).Insert Shift:=xlDown
Cells(i, ec + 1).Value = Cells(r, c).Value
Cells(i, ec + 2).Value = Trim(r)
Exit For
End If
End If
End If
Next i
Next r
For i = 1 To 3
n = Split(Cells(i, ec + 2).Value, ",")
For j = 0 To UBound(n)
Cells(n(j), c).Interior.ColorIndex = ci(i)
Next j
Next i
Next c
Range(Cells(1, ec + 1), Cells(er, ec + 2)).ClearContents
Application.ScreenUpdating = True
End Sub
Sub 陣列法()
Dim arr
Dim brr()
ci = Array(3, 8, 6)
arr = [A1].CurrentRegion
ec = UBound(arr, 2)
er = UBound(arr)
For c = 1 To ec
ReDim brr(3, 2)
For r = 1 To er
n = arr(r, c)
For i = 1 To 3
If n = brr(i, 1) Then
brr(i, 2) = brr(i, 2) & "," & r
Exit For
End If
If brr(i, 1) = "" Then
brr(i, 1) = n
brr(i, 2) = r
Exit For
Else
If n > brr(i, 1) Then
For j = 3 To i + 1 Step -1
brr(j, 1) = brr(j - 1, 1)
brr(j, 2) = brr(j - 1, 2)
Next j
brr(i, 1) = n
brr(i, 2) = r
Exit For
End If
End If
Next i
Next r
For i = 1 To 3
x = Split(brr(i, 2), ",")
For j = 0 To UBound(x)
Cells(x(j), c).Interior.ColorIndex = ci(i)
Next j
Next i
Next c
End Sub
Sub 排序()
ec = [A1].End(2).Column
er = [A65536].End(3).Row
Application.ScreenUpdating = False
For c = 1 To ec
Range(Cells(1, c), Cells(er, c)).Sort key1:=Cells(1, c), order1:=2
Next c
Application.ScreenUpdating = True
End Sub |
|
發表於 2016-4-10 21:09
| 
