hcm19522

http://blog.xuite.net/hcm19522/twblog/205029860

yen956

經過准大再三指導, 終於完成了, 謝謝准大.

下載 (409.46 KB)

2015-11-22 22:05

yen956

補檔:
http://forum.twbts.com/thread-15660-1-1.html
5#樓

yen956

回復 23# yen956
Sorry, 回應錯主題, 對 s7659109大大及相關讀者均非常抱歉,
已重新貼到下列主題中, 抱歉!!
http://forum.twbts.com/viewthrea ... a=pageD1&page=3

yen956

經准大再三指正, 終於完成

下載 (409.46 KB)

2015-11-23 16:03

顯示輸入值填滿顏色2.rar (28.32 KB)

下載次數: 1

2015-11-23 16:07

yen956

連續兩次都貼錯地方, 實在不可原諒!!
想貼的是這個!!
試試看!!
sheet1(設備列表)的VBA Code如下:

1. Option Explicit
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     Dim rngA As Range, rngB As Range, foundCel As Range
   
4.     Dim lastRow As Long
   
5.     If Target.Count > 1 Then Exit Sub         '如果一次Change太多格就離開
   
6.     lastRow = Sheets("公司清單").Cells(Rows.Count, 2).End(xlUp).Row
   
7.     Set rngA = Sheets("公司清單").Range("B2:B" & lastRow & "")   '設定 "公司清單" 的範圍給 rngA
   
8.     lastRow = Cells(Rows.Count, 2).End(xlUp).Row
   
9.     Set rngB = Range("B2:B" & lastRow & "")          '設定 "設備列表" 的範圍給 rngB
   
10.     If Not Intersect(Target, rngB) Is Nothing Then
    
11.         Set foundCel = rngA.Find(Target, lookat:=xlWhole)       'rngA 中尋找 Target
    
12.         If Not foundCel Is Nothing Then        '有找到
    
13.             Target.Offset(0, -1).Resize(1, 11).Interior.ColorIndex = _
    
14.                         foundCel.Offset(0, 1).Interior.ColorIndex
    
15. '        Else
    
16.             '建議 "設備列表" 的 "使用公司" 用 驗證清單 輸入
    
17.             '則此處就不必檢查輸入是否有錯誤, 換言之, 就沒有 Else 這一段
    
18.             '又 驗證清單 字體很小又不能改, 不適合弱視者,
    
19.             '建議 "設備列表" 整頁全部改用小字體, 再放大檢視比例
    
20.         End If
    
21.     End If
    
22. End Sub

複製代碼

sheet2(公司清單)的VBA Code如下:

1. Option Explicit
   
2. Public colorNum As Integer
   
3. 
   
4. '先執行此VBA一次, 以建立代碼表
   
5. Sub 顏色代碼表()
   
6.     Dim i As Integer
   
7.     For i = 1 To 28
   
8.         Cells(i, 15).Interior.ColorIndex = i
   
9.         Cells(i, 16).Interior.ColorIndex = i + 28
   
10.     Next
    
11. End Sub
    
12. 
    
13. '作用：用以編輯"公司清單"C欄的儲存格顏色
    
14. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
15.     Dim rng As Range
    
16.     If Target.Count > 1 Then Exit Sub
    
17.     Set rng = Application.Union([C:C], [O1:P28])
    
18.     If Intersect(Target, rng) Is Nothing Then Exit Sub
    
19.     If Target.Column = 3 Then
    
20.         Target.Interior.ColorIndex = colorNum
    
21.     Else
    
22.         colorNum = Target.Interior.ColorIndex
    
23.     End If
    
24. End Sub

複製代碼

下載 (155.18 KB)

2015-11-23 19:01

測試檔案.rar (381.48 KB)

下載次數: 4

2015-11-23 19:02