123
返回列表 上一主題 發帖

區域內顯示輸入值填滿顏色之問題

hcm19522

帖子
1387 
主題
4 
精華
0 
積分
1397 
點名
0  
作業系統
WIN 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2015-9-11 
最後登錄
2024-11-24 

熱烈參與勳章
11# 跳轉到 »
發表於 2015-11-13 21:09 | 只看該作者
http://blog.xuite.net/hcm19522/twblog/356624511
G21:L21與格式化 以 "准大" 精簡

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-23 
12#
發表於 2015-11-13 21:17 | 只看該作者
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

TOP

s7659109

帖子
248 
主題
76 
精華
0 
積分
331 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
性別
男 
來自
kaohsiung 
註冊時間
2013-6-10 
最後登錄
2020-7-3 
13#
發表於 2015-11-17 10:05 | 只看該作者
准大：
套用程式碼後，發現部分顏色對照有誤。
另每次有修改，需跳到程式碼頁面重新執行1次，
若要在工作底稿中加入快速鈕，是否可行？

問題40-標示-1.rar (16.24 KB)

希望支持!

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
14#
發表於 2015-11-18 11:40 | 只看該作者
試試看:
  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

  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
複製代碼
test.gif

TOP

s7659109

帖子
248 
主題
76 
精華
0 
積分
331 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
性別
男 
來自
kaohsiung 
註冊時間
2013-6-10 
最後登錄
2020-7-3 
15#
發表於 2015-11-18 14:04 | 只看該作者
進階問題：       
        1.當輸入區如輸入e100程式會出現錯誤，可否出現視窗方式表現？
        2.目前列輸入至18列，程式可否控制，當再輸入完列19時，自動再空出1列，原20列自動向下調整1列，以此類推!
        3.為何輸入區與順序列顏色會不一致。

問題40-標示-進階.rar (22.01 KB)

希望支持!

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
16#
發表於 2015-11-18 15:25 | 只看該作者
回復 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. 看不出輸入區與順序列顏色有何不一致?
不是有動畫圖可對照嗎?

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
17#
發表於 2015-11-18 15:45 | 只看該作者
回復 15# s7659109
Sorry, Q1 還沒有找到答案, 原想法會進入自我循環, Sorry!!

TOP

s7659109

帖子
248 
主題
76 
精華
0 
積分
331 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
性別
男 
來自
kaohsiung 
註冊時間
2013-6-10 
最後登錄
2020-7-3 
18#
發表於 2015-11-18 15:46 | 只看該作者
問題3：有附檔(工作表1)順2、3、4確實不一致(office2010)會有差嗎？
問題2：倘列19、20放到最前面，後面陸續增加，原程式碼是否函括在內，而可行？
希望支持!

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
19#
發表於 2015-11-18 19:00 | 只看該作者
回復 18# s7659109
問題2：沒錯, 只要在VBA中相關位址改一改就行了, 而且你的想法(放到最上面)更棒!!
問題3：不是2010的問題, 而是, 因為資料輸入錯誤(也就是前面的Q1問題),
我也不知道要如何改,
目前想到的是改用 CommandButton(被動執行),
不要用 Worksheet_Change(自動執行)才不會掉進自我循環中,
另請高明吧, Sorry!!

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
20#
發表於 2015-11-18 20:05 | 只看該作者
回復 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

TOP

        靜思自在 : 要比誰更受誰．不要比誰更怕誰。
123
返回列表 上一主題