excel vba判斷顏色取值範圍設定問題

zbc231

如上圖所示，資料在工作表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

首先加入這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

tryit244178 發表於 2017-2-8 06:12 AM

下載: 訪客無法瀏覽下載點，請先 註冊 或 登入會員

首先加入這2個副程式
然後在按鈕裡加入這行

請問一下，
格字內黑色的填滿是我運用格式化條件而達成的，
...

瀏覽完整內容，請先 註冊 或 登入會員

tryit244178

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

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

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

zbc231

tryit244178 發表於 2017-2-8 04:00 PM

下載: 訪客無法瀏覽下載點，請先 註冊 或 登入會員

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

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

...

瀏覽完整內容，請先 註冊 或 登入會員

zbc231

zbc231 發表於 2017-2-9 01:53 AM

下載: 訪客無法瀏覽下載點，請先 註冊 或 登入會員

目前的寫法為當初sheet1中格式化條件的寫法如下，
=COUNTIF(登錄區,C2)，
countif 不是VBA函數，而是excel ...

補充：
...

瀏覽完整內容，請先 註冊 或 登入會員

tryit244178

再加入這個函式

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

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

用這個試試

---

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

瀏覽完整內容，請先 註冊 或 登入會員

zbc231

tryit244178 發表於 2017-2-10 03:30 AM

下載: 訪客無法瀏覽下載點，請先 註冊 或 登入會員

用這個試試

---

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

...

瀏覽完整內容，請先 註冊 或 登入會員

tryit244178

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

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

還有，你登錄區的資料是放在哪個工作表？
...

瀏覽完整內容，請先 註冊 或 登入會員

zbc231

tryit244178 發表於 2017-2-10 06:10 PM

下載: 訪客無法瀏覽下載點，請先 註冊 或 登入會員

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

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

...

瀏覽完整內容，請先 註冊 或 登入會員

tryit244178

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

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() 是小寫轉大寫的函式

下載: 訪客無法瀏覽下載點，請先 註冊 或 登入會員

---

最後這段程序…看起來似乎是點到第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

tryit244178 發表於 2017-2-11 04:09 AM

下載: 訪客無法瀏覽下載點，請先 註冊 或 登入會員

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

...

瀏覽完整內容，請先 註冊 或 登入會員