返回列表 上一主題 發帖

[發問] 請大師們幫忙自動變換顏色,謝謝

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
1# 跳轉到 »
發表於 2015-11-15 20:46 | 顯示全部帖子
本帖最後由 yen956 於 2015-11-15 20:52 編輯

1. 在Module1中貼上下列VBA
  1. Public colorNum As Integer

  3. '先執行此VBA一次, 以建立代碼表(Sheet1)
  4. Sub 顏色代碼表()
  5.     Dim i As Integer
  6.     For i = 1 To 56
  7.         Sheets("Sheet1").Cells(i, 15) = i
  8.         Sheets("sheet1").Cells(i, 16).Interior.ColorIndex = i
  9.     Next
  10. End Sub
複製代碼
2. 在Sheet2中上下列VBA
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     If Target.Count > 1 Then Exit Sub
  3.     If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
  4.     Target.Interior.ColorIndex = colorNum
  5. End Sub
複製代碼
3. 在Sheet1中上下列VBA
  1. '尚未建立代碼表以前, 不要啟動此VBA
  2. '可先將 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  3. '改成 Private Sub Worksheet_SelectionChange2(ByVal Target As Range)
  4. '建立完代碼表後即可啟動此VBA, 目的是取得 colorNum 的值
  5. '最後再到 sheet2 中,點欄B的存儲格, 即可得到所要的顏色
  6. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  7.     If Target.Count > 1 Then Exit Sub
  8.     If Intersect(Target, [P1:P56]) Is Nothing Then Exit Sub
  9.     colorNum = Target.Interior.ColorIndex
  10. End Sub
複製代碼
換言之, 用兩個 Worksheet_SelectionChange 來達成
test.gif

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
2#
發表於 2015-11-15 21:11 | 顯示全部帖子
Sorry,全部貼在 sheet1 中就可以了
用Union就可以了
  1. Public colorNum As Integer

  3. '先執行此VBA一次, 以建立代碼表(Sheet1)
  4. Sub 顏色代碼表()
  5.     Dim i As Integer
  6.     For i = 1 To 56
  7.         Cells(i, 15) = i
  8.         Cells(i, 16).Interior.ColorIndex = i
  9.     Next
  10. End Sub

  12. '尚未建立代碼表以前, 不要啟動此VBA
  13. '建立完代碼表後即可啟動此VBA
  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([B:B], [P1:P56])
  18.     If Intersect(Target, rng) Is Nothing Then Exit Sub
  19.     If Target.Column = 16 Then
  20.         colorNum = Target.Interior.ColorIndex
  21.     Else
  22.         Target.Interior.ColorIndex = colorNum
  23.     End If
  24. End Sub
複製代碼
test.gif

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
3#
發表於 2015-11-22 22:05 | 顯示全部帖子
經過准大再三指導, 終於完成了, 謝謝准大.
test.gif

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
4#
發表於 2015-11-22 22:10 | 顯示全部帖子
補檔:
http://forum.twbts.com/thread-15660-1-1.html
5#樓

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
5#
發表於 2015-11-23 15:59 | 顯示全部帖子
回復 23# yen956
Sorry, 回應錯主題, 對 s7659109大大及相關讀者均非常抱歉,
已重新貼到下列主題中, 抱歉!!
http://forum.twbts.com/viewthrea ... a=pageD1&page=3

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
6#
發表於 2015-11-23 16:07 | 顯示全部帖子
經准大再三指正, 終於完成
test.gif
顯示輸入值填滿顏色2.rar (28.32 KB)

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
7#
發表於 2015-11-23 19:02 | 顯示全部帖子
連續兩次都貼錯地方, 實在不可原諒!!
想貼的是這個!!
試試看!!
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

  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

  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
複製代碼
test2.gif
測試檔案.rar (381.48 KB)

TOP

        靜思自在 : 【做人的開始】每一天都是故人的開始，每一個時刻都是自己的警惕。
返回列表 上一主題