麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 請大師們幫忙自動變換顏色,謝謝 [打印本頁]

作者: leirex1201 時間: 2015-5-8 18:27 標題: 請大師們幫忙自動變換顏色,謝謝

請教各位大師

我想要依"公司清單"這個sheet裡列的公司,讓"設備列表"這個sheet裡面的設備自動整列變色成為"公司清單"sheet內對應的顏色
因本身對顏色辨識能力較弱,其望可以有相應的色碼以供辨識
希望能相容於excel 2003~2010
請各位大師幫忙,感謝
[attach]20895[/attach]
[attach]20893[/attach][attach]20894[/attach]

作者: luhpro 時間: 2015-5-9 06:55

請教各位大師

我想要依"公司清單"這個sheet裡列的公司,讓"設備列表"這個sheet裡面的設備自動整列變色成為 ...
leirex1201 發表於 2015-5-8 18:27

印象中在 Excel 2003 似乎沒有可直接抓取儲存格底色的公式.

你的需求用 Excel VBA 較容易達成:

Private Sub cbGetColor_Click()
Dim lRow&
Dim vD
Set vD = CreateObject("Scripting.Dictionary")
lRow = 2
With Sheets("公司清單")
Do While .Cells(lRow, 1) <> ""
vD(.Cells(lRow, 2).Text) = .Cells(lRow, 3).Interior.ColorIndex
lRow = lRow + 1
Loop
End With
lRow = 2
With Sheets("設備列表")
Do While .Cells(lRow, 1) <> ""
.Rows(lRow).Interior.ColorIndex = vD(.Cells(lRow, 2).Text)
lRow = lRow + 1
Loop
End With
End Sub

複製代碼

當檔案內容有更新時,點一下 "更新底色" 按鈕即可.
[attach]20896[/attach]

作者: lpk187 時間: 2015-5-9 11:36

本帖最後由 lpk187 於 2015-5-9 11:38 編輯

回復 1# leirex1201

也可以用工作表事件來達成自動化
當B欄以後到E欄有變化時就會達成目的

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 1 And Target.Column < 6 And Cells(Target.Row, 2) <> "" Then
Set col = Sheets("公司清單").Columns(2).Find(Cells(Target.Row, 2), , , , , 2)
Range(Cells(Target.Row, 1), Cells(Target.Row, 1).End(xlToRight)).Interior.Color = _
col.Offset(0, 1).Interior.Color
End If
End Sub

複製代碼

[attach]20898[/attach]

作者: leirex1201 時間: 2015-5-11 10:00

印象中在 Excel 2003 似乎沒有可直接抓取儲存格底色的公式.

你的需求用 Excel VBA 較容易達成:當檔案內 ...
luhpro 發表於 2015-5-9 06:55

感謝luhpro大師回覆

請問要貼到wookbook嗎?謝謝

作者: leirex1201 時間: 2015-5-11 10:05

本帖最後由 leirex1201 於 2015-5-11 10:07 編輯

回復 leirex1201

也可以用工作表事件來達成自動化
當B欄以後到E欄有變化時就會達成目的
lpk187 發表於 2015-5-9 11:36

感謝lpk187大師回覆

If Target.Row > 1 And Target.Column < 10 And Cells(Target.Row, 1) <> "" Then
以上是change的事件範圍嗎
Range(Cells(Target.Row, 1), Cells(Target.Row, 1).End(xlToRight)).Interior.Color = _
col.Offset(0, 1).Interior.Color
但我不懂這個,
我想要設定變色的範圍,只要B欄位有值,不管後面的欄位有沒有值,比如A10~P10全部變色,請大師幫幫忙,謝謝

作者: lpk187 時間: 2015-5-11 10:24

回復 5# leirex1201
只有B欄的話可以改成這樣

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Cells(Target.Row, "B").Address Then
Set col = Sheets("公司清單").Columns(2).Find(Cells(Target.Row, 2), , , , , 2)
Range(Cells(Target.Row, 1), Cells(Target.Row, 5)).Interior.Color = _
col.Offset(0, 1).Interior.Color
End If
End Sub

複製代碼

作者: leirex1201 時間: 2015-5-11 10:44

回復 leirex1201
只有B欄的話可以改成這樣
lpk187 發表於 2015-5-11 10:24

感謝lpk187大大再一次幫忙

可能是我說明的不清楚
我的意思是A2有值"1",B2有值"遠傳電信",而C2:K2都是空白,但我想把A2:K2全部變色,感謝大師

作者: lpk187 時間: 2015-5-11 11:31

回復 7# leirex1201

嗯！那就改成下列

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 3 And Target.Row > 1 And Cells(Target.Row, "B") <> "" And Cells(Target.Row, "A") <> "" Then
Set col = Sheets("公司清單").Columns(2).Find(Cells(Target.Row, 2), , , , , 2)
Range(Cells(Target.Row, 1), Cells(Target.Row, 5)).Interior.Color = _
col.Offset(0, 1).Interior.Color
End If
End Sub

複製代碼

作者: lpk187 時間: 2015-5-11 11:41

回復 8# lpk187

改成下列的話，只要A欄和B欄其中一個無值的話回復空白

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 3 And Target.Row > 1 And Cells(Target.Row, "B") <> "" And Cells(Target.Row, "A") <> "" Then
Set col = Sheets("公司清單").Columns(2).Find(Cells(Target.Row, 2), , , , , 2)
AA = col.Offset(0, 1).Interior.Color
Range(Cells(Target.Row, 1), Cells(Target.Row, 5)).Interior.Color = _
col.Offset(0, 1).Interior.Color
Else
Range(Cells(Target.Row, 1), Cells(Target.Row, 5)).Interior.Color = 16777215
End If
End Sub

複製代碼

作者: leirex1201 時間: 2015-5-11 12:59

回復 lpk187

改成下列的話，只要A欄和B欄其中一個無值的話回復空白
lpk187 發表於 2015-5-11 11:41

感謝 lpk187 大師再次幫忙

不好意思,我可能還是沒表達清楚,我做了圖片如下
我想要達成如下圖這樣子,不管我在哪一column編輯,只要column(B)的值是符合"公司清單"sheet的值,那row(A2:K10)都變色
再次感謝^^
[attach]20922[/attach]

作者: lpk187 時間: 2015-5-11 13:15

回復 10# leirex1201

是只要A欄和B欄有值，然後從編輯的那一行A到K都變色對嗎？只要改紅字的部份就可以了
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 3 And Target.Row > 1 And Cells(Target.Row, "B") <> "" And Cells(Target.Row, "A") <> "" Then
Set col = Sheets("公司清單").Columns(2).Find(Cells(Target.Row, 2), , , , , 2)
AA = col.Offset(0, 1).Interior.Color
Range(Cells(Target.Row, 1), Cells(Target.Row, 11)).Interior.Color = _
col.Offset(0, 1).Interior.Color
Else
Range(Cells(Target.Row, 1), Cells(Target.Row, 11)).Interior.Color = 16777215
End If
End Sub

作者: leirex1201 時間: 2015-5-11 15:42

回復 leirex1201

是只要A欄和B欄有值，然後從編輯的那一行A到K都變色對嗎？只要改紅字的部份就可以了
...
lpk187 發表於 2015-5-11 13:15

感謝lpk187大師

測試已可以使用,我把最下面的else if拿掉了,不然編輯範圍以外的儲存格都會變成"白底色"
再次感謝lpk187大師的用心幫忙,感恩

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 11 And Target.Row > 1 And Cells(Target.Row, "B") <> "" And Cells(Target.Row, "A") <> "" Then
Set col = Sheets("公司清單").Columns(2).Find(Cells(Target.Row, 2), , , , , 2)
AA = col.Offset(0, 1).Interior.Color
Range(Cells(Target.Row, 1), Cells(Target.Row, 11)).Interior.Color = _
col.Offset(0, 1).Interior.Color
End If
End Sub

作者: leirex1201 時間: 2015-5-11 15:49

回復 leirex1201

是只要A欄和B欄有值，然後從編輯的那一行A到K都變色對嗎？只要改紅字的部份就可以了
...
lpk187 發表於 2015-5-11 13:15

對了,忘了請問lpk187大師
我本身對顏色辨識較弱,
如果沒有相對應的色碼,太相似的顏色分不太清楚
有辦法自動標示相對應的色碼嗎...例如RGB或CMYK或HTML的FFFFFF

謝謝大師

作者: lpk187 時間: 2015-5-11 19:19

回復 13# leirex1201

不用稱我大師，我也是初學者！

說實在的以上的程式碼，我也是看到你的問題之後去做巨集，然後想出來的，而我找到的方法都沒辦法對應到RGB
但可以用RGB填入色彩，是否能對應到RGB色碼，就要請教其他大大們了！我找到的只有以下程式碼
Sub 巨集1()
Range("A1:A2").Interior.Color = RGB(0, 255, 1)'A1:A2儲存格填入色彩
Range("B1") = Range("A1").Interior.Color '傳回A1物件的主要色彩
Range("B2") = Range("A2").Interior.ColorIndex '傳回A2代表內景色彩
End Sub

作者: luhpro 時間: 2015-5-11 23:44

感謝luhpro大師回覆

請問要貼到wookbook嗎?謝謝
leirex1201 發表於 2015-5-11 10:00

Private Sub cbGetColor_Click()
我是用按鈕事件來驅動,
每按一次就執行顏色檢核與變更.

作者: hcm19522 時間: 2015-11-15 12:22

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

作者: Airman 時間: 2015-11-15 17:30

[attach]22458[/attach]

請教各位大師

我想要依"公司清單"這個sheet裡列的公司,讓"設備列表"這個sheet裡面的設備自動整列變色成為 ...
leirex1201 發表於 2015-5-8 18:27

各顏色代碼~
在A1填上顏色，滑鼠離開A1移至任一儲存格後，B1可顯示該A1顏色的代碼。

Q1︰W7為各顏色代碼一覽表。

僅供參考。

作者: Airman 時間: 2015-11-15 17:36

不好意思~還不熟悉介面的操作~重發一次^^"

『因本身對顏色辨識能力較弱,其望可以有相應的色碼以供辨識』

各顏色代碼~
在A1填上顏色，滑鼠離開A1移至任一儲存格後，B1可顯示該A1顏色的代碼。

Q1︰W7為各顏色代碼一覽表。

http://www.FunP.Net/469452

僅供參考。

作者: yen956 時間: 2015-11-15 20:46

本帖最後由 yen956 於 2015-11-15 20:52 編輯

1. 在Module1中貼上下列VBA

Public colorNum As Integer
'先執行此VBA一次, 以建立代碼表(Sheet1)
Sub 顏色代碼表()
Dim i As Integer
For i = 1 To 56
Sheets("Sheet1").Cells(i, 15) = i
Sheets("sheet1").Cells(i, 16).Interior.ColorIndex = i
Next
End Sub

複製代碼

2. 在Sheet2中上下列VBA

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
Target.Interior.ColorIndex = colorNum
End Sub

複製代碼

3. 在Sheet1中上下列VBA

'尚未建立代碼表以前, 不要啟動此VBA
'可先將 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'改成 Private Sub Worksheet_SelectionChange2(ByVal Target As Range)
'建立完代碼表後即可啟動此VBA, 目的是取得 colorNum 的值
'最後再到 sheet2 中,點欄B的存儲格, 即可得到所要的顏色
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, [P1:P56]) Is Nothing Then Exit Sub
colorNum = Target.Interior.ColorIndex
End Sub

複製代碼

換言之, 用兩個 Worksheet_SelectionChange 來達成
[attach]22459[/attach]

作者: yen956 時間: 2015-11-15 21:11

Sorry,全部貼在 sheet1 中就可以了
用Union就可以了

Public colorNum As Integer
'先執行此VBA一次, 以建立代碼表(Sheet1)
Sub 顏色代碼表()
Dim i As Integer
For i = 1 To 56
Cells(i, 15) = i
Cells(i, 16).Interior.ColorIndex = i
Next
End Sub
'尚未建立代碼表以前, 不要啟動此VBA
'建立完代碼表後即可啟動此VBA
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rng As Range
If Target.Count > 1 Then Exit Sub
Set rng = Application.Union([B:B], [P1:P56])
If Intersect(Target, rng) Is Nothing Then Exit Sub
If Target.Column = 16 Then
colorNum = Target.Interior.ColorIndex
Else
Target.Interior.ColorIndex = colorNum
End If
End Sub

複製代碼

[attach]22460[/attach]

作者: hcm19522 時間: 2015-11-16 11:30

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

作者: yen956 時間: 2015-11-22 22:05

經過准大再三指導, 終於完成了, 謝謝准大.
[attach]22551[/attach]

作者: yen956 時間: 2015-11-22 22:10

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

作者: yen956 時間: 2015-11-23 15:59

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

作者: yen956 時間: 2015-11-23 16:07

經准大再三指正, 終於完成
[attach]22569[/attach]
[attach]22570[/attach]

作者: yen956 時間: 2015-11-23 19:02

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

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

複製代碼

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

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

複製代碼

[attach]22574[/attach]
[attach]22575[/attach]

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)