伊莉討論區

標題: excel vba判斷顏色取值範圍設定問題 [打印本頁]

---

作者: zbc231    時間: 2017-2-7 01:41 PM     標題: excel vba判斷顏色取值範圍設定問題

[attach]117630627[/attach]
如上圖所示，資料在工作表1中，
想在工作表2中回傳工作表1未變色的數值的名字部分，
如工作表2的內容，
網路上搜尋的語法下，

1. Option Explicit
   
2. Sub ex()
   
3.     Dim A As Range, A_Po As String
   
4.     Dim AA As Range, Sh As Worksheet
   
5.    
   
6.     'FindFormat 屬性 設定或傳回要尋找之儲存格格式類型的搜尋準則。
   
7.     With Application.FindFormat
   
8.         .Clear                      '清除以前的設定
   
9.        ' .Interior.Color = vbred    '設定儲存格圖樣顏色(紅色)
   
10.         .Interior.ColorIndex = 3   '設定儲存格圖樣顏色(紅色
    
11.     End With
    
12.     Set Sh = 工作表1
    
13.     Set A = Sh.Cells.Find("", AFTER:=Sh.Cells(Sh.Cells(1).Count), SearchFormat:=True) 'SearchFormat   選擇性的 Variant。搜尋的格式。
    
14.     Do While Not A Is Nothing
    
15.         If A_Po = "" Then
    
16.             A_Po = A.Address
    
17.             Set AA = A
    
18.         End If
    
19.         Set AA = Union(AA, A)
    
20.         Set A = Sh.Cells.Find(What:="", AFTER:=A, SearchFormat:=True) '下一個相同格式搜尋
    
21.         If A_Po = A.Address Then Exit Do
    
22.     Loop
    
23.     If Not A Is Nothing Then AA.Copy Sheets("工作表2").Range("A2")
    
24. End Sub

複製代碼

其中set sh部分設定是在工作表1中，
但我想在工作表2中分項找出未變黑的資料所對應的名字，
因此我試著在set sh=工作表1中加入範圍，如range("a2:a13")，
但都無法運作，因此向請問版上高手範圍的部分該在哪加入呢？
另外，工作表1中可能有七、八項資料，都需回傳到工作表2中，
有什麼寫法可以更精簡呢？還是就貼上七、八次就好了，
謝謝大家！
備註：語法中是紅色，圖示是黑色，是我忘了改，並非因此緣故而導致問題產生。

---

作者: tryit244178    時間: 2017-2-8 06:12 AM



首先加入這2個副程式

1. Private Sub CopyTransparentCell(ByVal seachRange As String)
   
2.     Dim i As Range
   
3.     Dim offestColumn As Integer
   
4.     Const Transparent As Long = 16777215
   
5.    
   
6.     For Each i In Sheet1.Range(seachRange)
   
7.         If i.Interior.Color = Transparent Then
   
8.             offestColumn = i.column - 1
   
9.             Sheet2.Cells(GetLastRow(offestColumn), offestColumn).value = Sheet1.Range("A" & i.Row).value
   
10.         End If
    
11.     Next i
    
12. End Sub
    
13. 
    
14. Private Function GetLastRow(ByVal column As Integer) As Integer
    
15.     GetLastRow = Sheet2.Cells(Sheet2.Cells.Rows.Count, column).End(xlUp).Row + 1
    
16. End Function

複製代碼

然後在按鈕裡加入這行

1.     CopyTransparentCell "B2:C13"

複製代碼

---

作者: zbc231    時間: 2017-2-8 03:13 PM

tryit244178 發表於 2017-2-8 06:12 AM
首先加入這2個副程式
然後在按鈕裡加入這行

請問一下，
格字內黑色的填滿是我運用格式化條件而達成的，
不是手動或是一開始便由黑色填滿的，
經過測試，
似乎是無法透過找色而篩選出來，
對嗎？

---

作者: tryit244178    時間: 2017-2-8 04:00 PM



那就把 If i.Interior.Color = Transparent Then 這行換成你的格式化條件

假如你的條件是儲存格內的值等於0，就改成
If Not i.Value = 0 Then

應該也能達到同樣的效果
記得把 Const Transparent As Long = 16777215 刪掉

---

作者: zbc231    時間: 2017-2-9 01:53 AM

tryit244178 發表於 2017-2-8 04:00 PM
那就把 If i.Interior.Color = Transparent Then 這行換成你的格式化條件

假如你的條件是儲存格內的值等於 ...

目前的寫法為

1. Option Explicit
   
2. 
   
3. Private Sub CopyTransparentCell(ByVal seachRange As String)
   
4.     Dim i As Range
   
5.     Dim offestColumn As Integer
   
6.     Const Transparent As Long = 16777215
   
7.     For Each i In Sheet1.Range(seachRange)
   
8.       If i.Interior.Color = Transparent Then
   
9.             offestColumn = i.column - 2
   
10.             工作表1.Cells(GetLastRow(offestColumn), offestColumn).Value = Sheet1.Range("B" & i.Row).Value
    
11.         End If
    
12.     Next i
    
13. End Sub
    
14. 
    
15. Private Function GetLastRow(ByVal column As Integer) As Integer
    
16.     GetLastRow = 工作表1.Cells(工作表1.Cells.Rows.Count, column).End(xlUp).Row + 1
    
17. End Function
    
18. 
    
19. Sub ex()
    
20.     Dim A As Range, A_Po As String
    
21.     Dim AA As Range, Sh As Worksheet
    
22.     With Application.FindFormat
    
23.         .Clear
    
24.         .Interior.Color = vbblack    '設定儲存格圖樣顏色
    
25.         .Interior.ColorIndex = 1   '設定儲存格圖樣顏色
    
26.     End With
    
27.     Set Sh = Sheet1
    
28.     Set A = Sh.Cells.Find("", AFTER:=Sh.Cells(Sh.Cells(1).Count), SearchFormat:=True)
    
29.     Do While Not A Is Nothing
    
30.         If A_Po = "" Then
    
31.             A_Po = A.Address
    
32.             Set AA = A
    
33.         End If
    
34.         Set AA = Union(AA, A)
    
35.         Set A = Sh.Cells.Find(What:="", AFTER:=A, SearchFormat:=True)
    
36.         If A_Po = A.Address Then Exit Do
    
37.     Loop
    
38.           CopyTransparentCell "C2:J26"
    
39. End Sub

複製代碼

當初sheet1中格式化條件的寫法如下，
=COUNTIF(登錄區,C2)，
countif 不是VBA函數，而是excel函數，
若要改成vba 函數該怎麼寫呢？
謝謝你！

---

作者: zbc231    時間: 2017-2-9 07:36 AM

zbc231 發表於 2017-2-9 01:53 AM
目前的寫法為當初sheet1中格式化條件的寫法如下，
=COUNTIF(登錄區,C2)，
countif 不是VBA函數，而是excel ...

補充：
sheet1中C2到J27為資料比對區，K2-V23為資料登錄區，
如果兩邊有重複的資料，
比對區的格子會自動反黑。

---

作者: tryit244178    時間: 2017-2-9 10:02 AM



再加入這個函式

1. Private Function ComparisonData(ByVal value As String, ByVal comparisonRange As String) As Boolean
   
2.     Dim i As Range
   
3.    
   
4.     ComparisonData = True
   
5.    
   
6.     For Each i In Sheet1.Range(comparisonRange)
   
7.         If value = i.value Then
   
8.             ComparisonData = False
   
9.             Exit For
   
10.         End If
    
11.     Next i
    
12. End Function

複製代碼

然後把 If i.Interior.Color = Transparent Then
換成 If ComparisonData(i.value, "K2:V23") Then

Const Transparent As Long = 16777215 記得刪掉

---

我發現你是把 CopyTransparentCell "C2:J26" 放在 ex() 裡面
其實可以不用ex()，而直接使用。因為這些程序並不是修改ex()用的

---

作者: zbc231    時間: 2017-2-10 02:22 AM

tryit244178 發表於 2017-2-9 10:02 AM
再加入這個函式
然後把 If i.Interior.Color = Transparent Then
換成 If ComparisonData(i.value, "K2:V23 ...

1. Option Explicit
   
2. Private Function ComparisonData(ByVal value As String, ByVal comparisonRange As String) As Boolean
   
3.     Dim i As Range
   
4.     ComparisonData = True
   
5.     For Each i In Sheet1.Range(comparisonRange)
   
6.         If value = i.value Then
   
7.             ComparisonData = False
   
8.             Exit For
   
9.         End If
   
10.     Next i
    
11. End Function
    
12. Private Sub CopyTransparentCell(ByVal seachRange As String)
    
13.     Dim i As Range
    
14.     Dim offestColumn As Integer
    
15.     For Each i In Sheet1.Range(seachRange)
    
16.       If ComparisonData(i.value, "K2:V23") Then
    
17.             offestColumn = i.column - 2
    
18.             工作表1.Cells(GetLastRow(offestColumn), offestColumn).value = Sheet1.Range("B" & i.Row).value
    
19.         End If
    
20.     Next i
    
21. End Sub
    
22. Private Function GetLastRow(ByVal column As Integer) As Integer
    
23.     GetLastRow = 工作表1.Cells(工作表1.Cells.Rows.Count, column).End(xlUp).Row + 1
    
24. End Function
    
25. Sub ex()
    
26.     Dim A As Range, A_Po As String
    
27.     Dim AA As Range, Sh As Worksheet
    
28.     With Application.FindFormat
    
29.         .Clear
    
30.         .Interior.Color = vbBlack    '設定儲存格圖樣顏色
    
31.         .Interior.ColorIndex = 1   '設定儲存格圖樣顏色
    
32.     End With
    
33.     Set Sh = Sheet1
    
34.     Set A = Sh.Cells.Find("", AFTER:=Sh.Cells(Sh.Cells(1).Count), SearchFormat:=True)
    
35.     Do While Not A Is Nothing
    
36.         If A_Po = "" Then
    
37.             A_Po = A.Address
    
38.             Set AA = A
    
39.         End If
    
40.         Set AA = Union(AA, A)
    
41.         Set A = Sh.Cells.Find(What:="", AFTER:=A, SearchFormat:=True)
    
42.         If A_Po = A.Address Then Exit Do
    
43.     Loop
    
44.    CopyTransparentCell "C2:J26"
    
45. End Sub

複製代碼

目前的寫法修正如下，
但似乎還是無法達成，
現在連手動將格子填滿還是會抓到全部的資料，
不像之前還能挑出。
是上述的程式順序要更換嗎？
另外，

1.   CopyTransparentCell "C2:J26"

複製代碼

是要放在哪裡呢？
如果放在最後的話，
excel會出現編譯錯誤，只有註解可以放在endsub.end function.或end property後面，
所以我才會放在ex()裡面，
還是我放錯位置導致無法順利執行？
以上兩個問題再麻煩你了。

---

作者: tryit244178    時間: 2017-2-10 03:30 AM



用這個試試

---

順便說明一下
offestColumn = i.column - 1
這個是你要貼到 工作表2 的位置
減 1 的話，就是貼到 A 欄；減 0 就是 B 欄；加 1 就是 C 欄…以此類推

工作表2.Cells(GetLastRow(offestColumn), offestColumn).value = 工作表1.Range("A" & i.Row).value
後面的 工作表1.Range("A" & i.Row).value 就是指是把你的 工作表1 的 姓名欄 的值傳給 工作表2 的最下列
你改成 B 就變成把 工作表1 的 項目1 欄的值傳給 工作表2
位置就錯啦

1. Option Explicit
   
2. 
   
3. Private Function ComparisonData(ByVal value As String, ByVal comparisonRange As String) As Boolean
   
4.     Dim i As Range
   
5.     ComparisonData = True
   
6.     For Each i In 工作表1.Range(comparisonRange)
   
7.         If value = i.value Then
   
8.             ComparisonData = False
   
9.             Exit For
   
10.         End If
    
11.     Next i
    
12. End Function
    
13. 
    
14. Private Sub CopyTransparentCell(ByVal seachRange As String)
    
15.     Dim i As Range
    
16.     Dim offestColumn As Integer
    
17.     For Each i In 工作表1.Range(seachRange)
    
18.       If ComparisonData(i.value, "K2:V23") Then
    
19.             offestColumn = i.column - 1
    
20.             工作表2.Cells(GetLastRow(offestColumn), offestColumn).value = 工作表1.Range("A" & i.Row).value
    
21.         End If
    
22.     Next i
    
23. End Sub
    
24. 
    
25. Private Function GetLastRow(ByVal column As Integer) As Integer
    
26.     GetLastRow = 工作表2.Cells(工作表2.Cells.Rows.Count, column).End(xlUp).Row + 1
    
27. End Function
    
28. 
    
29. Sub ex()
    
30.    CopyTransparentCell "C2:J26"
    
31. End Sub

複製代碼

註：如果找不到物件的話。把 工作表1 和 工作表2 改成 Worksheets("工作表1") 和 Worksheets("工作表2")

---

作者: zbc231    時間: 2017-2-10 06:25 AM

tryit244178 發表於 2017-2-10 03:30 AM
用這個試試

---

順便說明一下
offestColumn = i.column - 1
這個是你要貼到 工作表2 的位置[/ba ...

可能是我的工作表1在名字前還有個編號，
所以在offestColumn = i.column - 1中，
減 1 的話，就是貼到 B 欄；所以我才改成-2，
這樣才會貼到A欄。
接續前面的部分，改成B只要是要回傳名字，
若是A則是回傳號碼，這部分我是有修改過。
以上兩點均是我在敘述時跟實作不同之處，
讓你因此多費心，真是感到抱歉。
測試後，他還是把所有資料貼出，沒有篩選。
因此想問一下可以改成另一種寫法嗎？
我主要是要將Sheet1比對區C2:J26跟登錄區K2:V23作資料比對，
再將只出現一次的資料所有人名字(就是比對區有資料，登錄區沒有，表示沒繳交)回傳到Sheet2，
以便我能一眼就了解狀況。
格子變色只是方便繳交人了解是否繳交，
並不一定要依此為判斷依據。
這樣的話，該怎麼寫呢？

---

作者: tryit244178    時間: 2017-2-10 06:10 PM



最新的程序其實做得就是你說的那些事。(一開始是判斷顏色就是)

從你的描述來看，代表比對出來結果，全被判斷為不同
你貼出來的圖裡，比對區放的值都是數字
登錄區裡放的也是數字嗎？
還是有什麼特殊條件，才會造成放到比對區裡的數字？

還有，你登錄區的資料是放在哪個工作表？
如果不是工作表1的話
函式 ComparisonData() 裡的 For Each i In 工作表1.Range(comparisonRange)
工作表1 要換為你登錄區的工作表名

目前只想到這2種可能會造成比對結果全部不同
你想想看，你的環境下，還有什麼可能性

---

作者: zbc231    時間: 2017-2-11 03:21 AM

tryit244178 發表於 2017-2-10 06:10 PM
最新的程序其實做得就是你說的那些事。(一開始是判斷顏色就是)

從你的描述來看，代表比對出來結果，全被判 ...

我終於找到問題了，
那便是大小寫。
比對區為A01，
但是輸入區為a01，
所以才會出現沒有相同數值的狀況。
為了解決此情形，
我參閱網路上的方法在sheet1內加入下列程式碼，

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Application.EnableEvents = False
   
3. Target = UCase(Target)
   
4. Application.EnableEvents = True
   
5. End Sub

複製代碼

在登錄區輸入時，的確小寫會變成大寫，
但我啟動清除資料的巨集時，
便會跳出偵錯畫面說型態不符合，
然後下列句子反黃，

1. Target = UCase(Target)

複製代碼

清除資料的巨集如下，

1. Sub click()
   
2. Workbooks("紀錄表.xls").Sheets("LIST").Range(Cells(2, 11), Cells(23, 22)).ClearContents
   
3. End Sub

複製代碼

這兩個功能是哪裡相沖呢？
另外在sheet1還有一段程式碼如下，

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. If Target.Row = 24 Then Cells(2, Target.Column + 1).Select
   
3. End Sub

複製代碼

這段程式碼不知道是我為了什麼作用貼上的，
可以告訴我它的功用嗎？
以上兩個問題，非常感謝你一路的回答。

---

作者: tryit244178    時間: 2017-2-11 04:09 AM



因為一次清除了很多儲存格
但轉大寫的函式，一次只能轉一個儲存格，所以會產生錯誤
把最上面的程序改為

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim i As Range
   
3.    
   
4.     Application.EnableEvents = False
   
5.     For Each i In Target
   
6.         If Not i = "" Then
   
7.             i = UCase(i)
   
8.         End If
   
9.     Next i
   
10.     Application.EnableEvents = True
    
11. End Sub

複製代碼

---

UCase() 是小寫轉大寫的函式
https://msdn.microsoft.com/zh-tw/library/53e2ew8a(v=vs.90).aspx

---

最後這段程序…看起來似乎是點到第24行的時候會跳到下一欄的第2行
大概是懶得換行吧XD

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Target.Row = 24 Then Cells(2, Target.column + 1).Select  '懶得換行
   
3. End Sub

複製代碼

你可以像這樣為程序註解，『'』(冒號右邊那顆鍵)

---

作者: zbc231    時間: 2017-2-11 07:04 AM

tryit244178 發表於 2017-2-11 04:09 AM
因為一次清除了很多儲存格
但轉大寫的函式，一次只能轉一個儲存格，所以會產生錯誤
把最上面的程序改為

終於完成了，
最後那段程序是我之前要讓他自動換行加的，
但是因為也是找資料來的，
所以就忘了。
最近三份excel都是麻煩你幫忙解決，
真是非常感謝你的指導。

---

歡迎光臨 伊莉討論區 (http://a401.file-static.com/)

Powered by Discuz!