- 帖子
- 522
- 主題
- 36
- 精華
- 1
- 積分
- 603
- 點名
- 0
- 作業系統
- win xp sp3
- 軟體版本
- Office 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-12-13
- 最後登錄
- 2021-7-11
|
26#
發表於 2015-11-23 18:09
| 只看該作者
回復 25# s7659109
(這一兩天老是回錯主題, 連貼兩次都貼錯地方, 真奇怪!),
經准大再三指正後, 總算完成了!!
試試看:- Option Explicit
- Public inAllNum As Integer
- Public inNowNum As Integer
- Function BigRng() As Range
- Dim rL As String, I As Integer
- rL = Split([B5].End(xlToRight).Address, "$")(1)
- Set BigRng = Range("B5:" & rL & [B5].End(xlDown).Row & "")
- BigRng.Select
- Selection.Interior.ColorIndex = xlNone '清除底色
- For I = 1 To 4
- Selection.Borders(I).LineStyle = xlNone '清除格線
- Next
- ' For I = 7 To 10
- ' Selection.Borders(I).LineStyle = xlNone
- ' Next
- End Function
- Function SmallRng() As Range
- Dim rL As String, I As Integer
- rL = Split([B5].End(xlToRight).Address, "$")(1)
- Set SmallRng = Range("B" & [D2] & ":" & rL & [D3] & "") '設定啟始列與終止列之為搜尋範圍
- End Function
- Function inputRng() As Range
- Dim rL As String, cNumAr
- Dim str1 As String, I As Integer
- cNumAr = Array(4, 6, 7, 8, 15, 17, 19, 20, 22, 24, 33, 35, 36, 37, 39, 40) '挑選淺色系
- Rows("1:3").Interior.ColorIndex = xlNone '清除輸入區底色
- rL = Split([G1].End(xlToRight).Address, "$")(1)
- Range("G3:" & rL & "3") = "" '清除統計結果
- inAllNum = [G1].End(xlToRight).Column - 6 '輸入區共有幾格
- inNowNum = [G2].End(xlToRight).Column - 6 '目前已經輸入幾格
- [F1].FormulaR1C1 = "=SUMPRODUCT((R[1]C[1]:R[1]C[" & inAllNum & "]<>"""")/COUNTIF(R[1]C[1]:R[1]C[" & inAllNum & "],R[1]C[1]:R[1]C[" & inAllNum & "]&""""))"
- For I = 7 To 6 + inAllNum
- Cells(1, I).Resize(3).Interior.ColorIndex = cNumAr(I - 7)
- Next
- str1 = "G2:" & rL & "2"
- Set inputRng = Range(str1)
- End Function
- Sub 開始統計()
- Dim inRng As Range, bRng As Range, sRng As Range
- Dim Rng As Range, Cel As Range
- Dim FstAddr As String
- Dim ndx As Integer, cNum As Integer
- Set bRng = BigRng
- Set sRng = SmallRng
- Set inRng = inputRng
-
- '先搜尋大範圍
- For Each Cel In inRng
- If Cel = "" Then Exit For
- On Error Resume Next '忽略錯誤繼續執行 VBA 代碼, 避免出現錯誤消息
- Set Cel = bRng.Find(What:=Cel, LookAt:=xlWhole) '在大範圍中搜尋
- If Cel Is Nothing Then
- MsgBox "注意:" & Chr(10) & "資料輸入錯誤!!" & Chr(10) & "請修正!!", vbCritical
- Exit Sub
- End If
- Next
- '再搜尋小範圍
- For Each Cel In inRng
- Cel.Activate
- cNum = Cel.Interior.ColorIndex
- ndx = 0
- On Error Resume Next '忽略錯誤繼續執行 VBA 代碼, 避免出現錯誤消息
- sRng.Find(What:=Cel, LookAt:=xlWhole).Activate
- If ActiveCell.Address = Cel.Address Then GoTo next1 '如果原地踏就是找不到
- '如果有找到, ... ...
- ActiveCell.Interior.ColorIndex = cNum
- FstAddr = ActiveCell.Address
- Do
- ndx = ndx + 1
- sRng.FindNext(After:=ActiveCell).Activate '繼續找下一個
- ActiveCell.Interior.ColorIndex = cNum
- Loop Until FstAddr = ActiveCell.Address '直到回到第一次找到的儲存格
- next1:
- Cel.Offset(1, 0) = ndx '統計值寫入 ndx, 換下一格
- Next
- End Sub
- Private Sub CommandButton1_Click()
- Dim Rng As Range, inRng As Range, bRng As Range, sRng As Range
- Dim I As Integer
- Set bRng = BigRng
- Set sRng = SmallRng
- Set inRng = inputRng
-
- If Val([D2]) < 5 Then
- MsgBox "注意:" & Chr(10) & "判斷條件的啟始列的值 不可小於 5!!", vbCritical
- Exit Sub
- End If
- If Val([D3]) > [B5].End(xlDown).Row Then
- MsgBox "注意:" & Chr(10) & "判斷條件的終止列的值 不可大於" & [B5].End(xlDown).Row & "!!", vbCritical
- Exit Sub
- End If
- If Val([D2]) > Val([D3]) Then '如果 啟始列的值 大於 終止列的值
- MsgBox "注意:" & Chr(10) & "啟始列的值 不可以大於 終止列的值!!", vbCritical
- Exit Sub
- End If
- If inNowNum < inAllNum Then
- MsgBox "注意:" & Chr(10) & "輸入區尚未填满前," & Chr(10) & "請勿按【開始統計】!!", vbCritical
- Exit Sub '如果輸入區未滿格, 離開
- End If
- If Val([F1]) < inNowNum Then
- MsgBox "注意:" & Chr(10) & "輸入區的值重覆," & Chr(10) & "請修正!!", vbCritical
- Exit Sub
- End If
- 開始統計
- SmallRng.Select
- For I = 7 To 10
- With Selection.Borders(I) '畫格線
- .LineStyle = xlContinuous
- .Weight = xlMedium
- End With
- Next
- End Sub
 顯示輸入值填滿顏色2.rar (28.32 KB)
|
|
