hcm19522

http://blog.xuite.net/hcm19522/twblog/356624511
G21:L21與格式化 以 "准大" 精簡

准提部林

Sub 執行()
Dim xR As Range, MH, Brr
[B2:X18].Interior.ColorIndex = 0
[G21:L21].ClearContents
Brr = [G21:L21]
For Each xR In Range("B" & Replace([C20], "-", ":X"))
　　MH = Application.Match(xR, [G20:L20], 0)
　　If IsNumeric(MH) Then
　　　　xR.Interior.ColorIndex = [G19].Cells(1, MH).Interior.ColorIndex
　　　　Brr(1, MH) = Brr(1, MH) + 1
　　End If
Next
[G21:L21] = Brr
End Sub

s7659109

准大：
套用程式碼後，發現部分顏色對照有誤。
另每次有修改，需跳到程式碼頁面重新執行1次，
若要在工作底稿中加入快速鈕，是否可行？

yen956

試試看:

1. Sub 開始統計()
   
2.     Dim Cel As Range, Rng As Range
   
3.     Dim FstAddr As String, ndx As Integer, cNum As Integer
   
4.     Set Rng = Range("B" & [B21] & ":X" & [C21] & "")
   
5.     cNum = 0
   
6.     For Each Cel In [G20:L20]
   
7.         cNum = Cel.Offset(-1, 0).Interior.ColorIndex
   
8.         Cel.Interior.ColorIndex = cNum
   
9.         ndx = 0
   
10.         On Error GoTo next1
    
11.         Rng.Find(What:=Cel, LookIn:=xlFormulas, LookAt:=xlWhole).Activate
    
12.         FstAddr = ActiveCell.Address
    
13.         Cel.Interior.ColorIndex = cNum
    
14.         ActiveCell.Interior.ColorIndex = cNum
    
15.         Do
    
16.             ndx = ndx + 1
    
17.             On Error GoTo next1
    
18.             Rng.FindNext(After:=ActiveCell).Activate
    
19.             ActiveCell.Interior.ColorIndex = cNum
    
20.         Loop Until FstAddr = ActiveCell.Address
    
21. next1:
    
22.         Cel.Offset(1, 0) = ndx
    
23.     Next
    
24. End Sub
    
25. 
    
26. Private Sub Worksheet_Change(ByVal Target As Range)
    
27.     Dim Rng As Range
    
28.     Set Rng = Application.Union([B21:C21], [G20:L20])
    
29.     If Intersect(Target, Rng) Is Nothing Then Exit Sub
    
30.     If Not Intersect(Target, [B21:C21]) Is Nothing Then
    
31.         [B2:X18].Interior.ColorIndex = xlNone
    
32.         [G20:L20].Interior.ColorIndex = xlNone
    
33.         [G21:L21] = ""
    
34.         If [B21] > [C21] Then
    
35.             MsgBox "注意:" & Chr(10) & "啟始列的值 不可以大於 終止列的值", vbCritical
    
36.             Exit Sub
    
37.         End If
    
38.     End If
    
39.     If Not Intersect(Target, [G20:L20]) Is Nothing Then
    
40.         [B2:X18].Interior.ColorIndex = xlNone
    
41.         [G20:L20].Interior.ColorIndex = xlNone
    
42.         [G21:L21] = ""
    
43.         [N21] = "= COUNTA(G20:L20)"
    
44.         If [N21] <> 6 Then Exit Sub
    
45.         [N20] = "=SUMPRODUCT((G20:L20<>"""")/COUNTIF(G20:L20,G20:L20&""""))"
    
46.         If [N20] < 6 Then
    
47.             MsgBox "注意:" & Chr(10) & "輸入區資料重覆!!", vbCritical
    
48.             Exit Sub
    
49.         End If
    
50.     End If
    
51.     開始統計
    
52. End Sub

複製代碼

下載 (92.73 KB)

2015-11-18 11:40

s7659109

進階問題：       
        1.當輸入區如輸入e100程式會出現錯誤，可否出現視窗方式表現？
        2.目前列輸入至18列，程式可否控制，當再輸入完列19時，自動再空出1列，原20列自動向下調整1列，以此類推!
        3.為何輸入區與順序列顏色會不一致。

yen956

回復 15# s7659109
以#14F 為例回覆:
Q1. 在倒數第4列
(即在49與50列之間)
插入
        On Error Resume Next
        [B2:X18].Find(What:=Target, LookIn:=xlFormulas, LookAt:=xlWhole).Activate
        MsgBox "注意:" & Chr(10) & "資料輸入錯誤!!", vbCritical
        Exit Sub
即可.
Q2. 這是版面設計問題,
何不將輸入區直放到到最下面?
中間列空白列可暫先穏藏?
Q3. 看不出輸入區與順序列顏色有何不一致?
不是有動畫圖可對照嗎?

yen956

回復 15# s7659109
Sorry, Q1 還沒有找到答案, 原想法會進入自我循環, Sorry!!

s7659109

問題3：有附檔(工作表1)順2、3、4確實不一致(office2010)會有差嗎？
問題2：倘列19、20放到最前面，後面陸續增加，原程式碼是否函括在內，而可行？

yen956

回復 18# s7659109
問題2：沒錯, 只要在VBA中相關位址改一改就行了, 而且你的想法(放到最上面)更棒!!
問題3：不是2010的問題, 而是, 因為資料輸入錯誤(也就是前面的Q1問題),
我也不知道要如何改,
目前想到的是改用 CommandButton(被動執行),
不要用 Worksheet_Change(自動執行)才不會掉進自我循環中,
另請高明吧, Sorry!!

yen956

回復 13# s7659109
試試看:
我試過好像沒問題
還是舊的檔, 問題40-標示-1.rar, 但b21,c21 有改
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range, Cel As Range
    Set Rng = Application.Union([B21:C21], [G20:L20])
    If Intersect(Target, Rng) Is Nothing Then Exit Sub
    If Not Intersect(Target, [B21:C21]) Is Nothing Then
        [B2:X18].Interior.ColorIndex = xlNone
        [G20:L20].Interior.ColorIndex = xlNone
        [G21:L21] = ""
        If [B21] > [C21] Then
            MsgBox "注意:" & Chr(10) & "啟始列的值 不可以大於 終止列的值", vbCritical
            Exit Sub
        End If
    End If
    Set Rng = Range("B" & [B21] & ":X" & [C21] & "")
    If Not Intersect(Target, [G20:L20]) Is Nothing Then
        [B2:X18].Interior.ColorIndex = xlNone
        [G20:L20].Interior.ColorIndex = xlNone
        [G21:L21] = ""
        On Error Resume Next
        Set Cel = Rng.Find(What:=Target, LookIn:=xlFormulas, LookAt:=xlWhole)
        If Cel Is Nothing Then
            MsgBox "注意:" & Chr(10) & "資料輸入錯誤!!", vbCritical
            Exit Sub
        End If
        [N21] = "= COUNTA(G20:L20)"
        If [N21] <> 6 Then Exit Sub
        [N20] = "=SUMPRODUCT((G20:L20<>"""")/COUNTIF(G20:L20,G20:L20&""""))"
        If [N20] < 6 Then
            MsgBox "注意:" & Chr(10) & "輸入區資料重覆!!", vbCritical
            Exit Sub
        End If
    End If
    開始統計
End Sub