查看完整版本: excel vba判斷顏色取值範圍設定問題

論壇 › Visual Basic 語言 › excel vba判斷顏色取值範圍設定問題

zbc231 發表於 2017-2-7 01:41 PM

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

如上圖所示，資料在工作表1中，
想在工作表2中回傳工作表1未變色的數值的名字部分，
如工作表2的內容，
網路上搜尋的語法下，
Option Explicit
Sub ex()
    Dim A As Range, A_Po As String
    Dim AA As Range, Sh As Worksheet
   
    'FindFormat 屬性 設定或傳回要尋找之儲存格格式類型的搜尋準則。
    With Application.FindFormat
        .Clear                      '清除以前的設定
       ' .Interior.Color = vbred    '設定儲存格圖樣顏色(紅色)
        .Interior.ColorIndex = 3   '設定儲存格圖樣顏色(紅色
    End With
    Set Sh = 工作表1
    Set A = Sh.Cells.Find("", AFTER:=Sh.Cells(Sh.Cells(1).Count), SearchFormat:=True) 'SearchFormat   選擇性的 Variant。搜尋的格式。
    Do While Not A Is Nothing
        If A_Po = "" Then
            A_Po = A.Address
            Set AA = A
        End If
        Set AA = Union(AA, A)
        Set A = Sh.Cells.Find(What:="", AFTER:=A, SearchFormat:=True) '下一個相同格式搜尋
        If A_Po = A.Address Then Exit Do
    Loop
    If Not A Is Nothing Then AA.Copy Sheets("工作表2").Range("A2")
End Sub其中set sh部分設定是在工作表1中，
但我想在工作表2中分項找出未變黑的資料所對應的名字，
因此我試著在set sh=工作表1中加入範圍，如range("a2:a13")，
但都無法運作，因此向請問版上高手範圍的部分該在哪加入呢？
另外，工作表1中可能有七、八項資料，都需回傳到工作表2中，
有什麼寫法可以更精簡呢？還是就貼上七、八次就好了，
謝謝大家！
備註：語法中是紅色，圖示是黑色，是我忘了改，並非因此緣故而導致問題產生。
...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div><div></div>

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

本帖最後由 tryit244178 於 2017-2-8 10:22 AM 編輯

首先加入這2個副程式Private Sub CopyTransparentCell(ByVal seachRange As String)
    Dim i As Range
    Dim offestColumn As Integer
    Const Transparent As Long = 16777215
   
    For Each i In Sheet1.Range(seachRange)
        If i.Interior.Color = Transparent Then
            offestColumn = i.column - 1
            Sheet2.Cells(GetLastRow(offestColumn), offestColumn).value = Sheet1.Range("A" & i.Row).value
        End If
    Next i
End Sub

Private Function GetLastRow(ByVal column As Integer) As Integer
    GetLastRow = Sheet2.Cells(Sheet2.Cells.Rows.Count, column).End(xlUp).Row + 1
End Function
然後在按鈕裡加入這行
    CopyTransparentCell "B2:C13"...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div>

zbc231 發表於 2017-2-8 03:13 PM

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

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

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

本帖最後由 tryit244178 於 2017-2-11 04:18 AM 編輯

那就把 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

本帖最後由 zbc231 於 2017-2-9 07:36 AM 編輯

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

假如你的條件是儲存格內的值等於 ...
目前的寫法為Option Explicit

Private Sub CopyTransparentCell(ByVal seachRange As String)
    Dim i As Range
    Dim offestColumn As Integer
    Const Transparent As Long = 16777215
    For Each i In Sheet1.Range(seachRange)
      If i.Interior.Color = Transparent Then
            offestColumn = i.column - 2
            工作表1.Cells(GetLastRow(offestColumn), offestColumn).Value = Sheet1.Range("B" & i.Row).Value
        End If
    Next i
End Sub

Private Function GetLastRow(ByVal column As Integer) As Integer
    GetLastRow = 工作表1.Cells(工作表1.Cells.Rows.Count, column).End(xlUp).Row + 1
End Function

Sub ex()
    Dim A As Range, A_Po As String
    Dim AA As Range, Sh As Worksheet
    With Application.FindFormat
        .Clear
        .Interior.Color = vbblack    '設定儲存格圖樣顏色
        .Interior.ColorIndex = 1   '設定儲存格圖樣顏色
    End With
    Set Sh = Sheet1
    Set A = Sh.Cells.Find("", AFTER:=Sh.Cells(Sh.Cells(1).Count), SearchFormat:=True)
    Do While Not A Is Nothing
        If A_Po = "" Then
            A_Po = A.Address
            Set AA = A
        End If
        Set AA = Union(AA, A)
        Set A = Sh.Cells.Find(What:="", AFTER:=A, SearchFormat:=True)
        If A_Po = A.Address Then Exit Do
    Loop
          CopyTransparentCell "C2:J26"
End Sub
當初sheet1中格式化條件的寫法如下，
=COUNTIF(登錄區,C2)，
countif 不是VBA函數，而是excel函數，
若要改成vba 函數該怎麼寫呢？
謝謝你！



...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div><br><br><br><br><br><div></div>

zbc231 發表於 2017-2-9 07:36 AM

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

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

tryit244178 發表於 2017-2-9 10:02 AM

本帖最後由 tryit244178 於 2017-2-11 04:18 AM 編輯

再加入這個函式Private Function ComparisonData(ByVal value As String, ByVal comparisonRange As String) As Boolean
    Dim i As Range
   
    ComparisonData = True
   
    For Each i In Sheet1.Range(comparisonRange)
        If value = i.value Then
            ComparisonData = False
            Exit For
        End If
    Next i
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()用的
...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div>

zbc231 發表於 2017-2-10 02:22 AM

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

Option Explicit
Private Function ComparisonData(ByVal value As String, ByVal comparisonRange As String) As Boolean
    Dim i As Range
    ComparisonData = True
    For Each i In Sheet1.Range(comparisonRange)
        If value = i.value Then
            ComparisonData = False
            Exit For
        End If
    Next i
End Function
Private Sub CopyTransparentCell(ByVal seachRange As String)
    Dim i As Range
    Dim offestColumn As Integer
    For Each i In Sheet1.Range(seachRange)
      If ComparisonData(i.value, "K2:V23") Then
            offestColumn = i.column - 2
            工作表1.Cells(GetLastRow(offestColumn), offestColumn).value = Sheet1.Range("B" & i.Row).value
        End If
    Next i
End Sub
Private Function GetLastRow(ByVal column As Integer) As Integer
    GetLastRow = 工作表1.Cells(工作表1.Cells.Rows.Count, column).End(xlUp).Row + 1
End Function
Sub ex()
    Dim A As Range, A_Po As String
    Dim AA As Range, Sh As Worksheet
    With Application.FindFormat
        .Clear
        .Interior.Color = vbBlack    '設定儲存格圖樣顏色
        .Interior.ColorIndex = 1   '設定儲存格圖樣顏色
    End With
    Set Sh = Sheet1
    Set A = Sh.Cells.Find("", AFTER:=Sh.Cells(Sh.Cells(1).Count), SearchFormat:=True)
    Do While Not A Is Nothing
        If A_Po = "" Then
            A_Po = A.Address
            Set AA = A
        End If
        Set AA = Union(AA, A)
        Set A = Sh.Cells.Find(What:="", AFTER:=A, SearchFormat:=True)
        If A_Po = A.Address Then Exit Do
    Loop
   CopyTransparentCell "C2:J26"
End Sub目前的寫法修正如下，
但似乎還是無法達成，
現在連手動將格子填滿還是會抓到全部的資料，
不像之前還能挑出。
是上述的程式順序要更換嗎？
另外，  CopyTransparentCell "C2:J26"是要放在哪裡呢？
如果放在最後的話，
excel會出現編譯錯誤，只有註解可以放在endsub.end function.或end property後面，
所以我才會放在ex()裡面，
還是我放錯位置導致無法順利執行？
以上兩個問題再麻煩你了。...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div>

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

本帖最後由 tryit244178 於 2017-2-11 04:18 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
位置就錯啦
Option Explicit

Private Function ComparisonData(ByVal value As String, ByVal comparisonRange As String) As Boolean
    Dim i As Range
    ComparisonData = True
    For Each i In 工作表1.Range(comparisonRange)
        If value = i.value Then
            ComparisonData = False
            Exit For
        End If
    Next i
End Function

Private Sub CopyTransparentCell(ByVal seachRange As String)
    Dim i As Range
    Dim offestColumn As Integer
    For Each i In 工作表1.Range(seachRange)
      If ComparisonData(i.value, "K2:V23") Then
            offestColumn = i.column - 1
            工作表2.Cells(GetLastRow(offestColumn), offestColumn).value = 工作表1.Range("A" & i.Row).value
        End If
    Next i
End Sub

Private Function GetLastRow(ByVal column As Integer) As Integer
    GetLastRow = 工作表2.Cells(工作表2.Cells.Rows.Count, column).End(xlUp).Row + 1
End Function

Sub ex()
   CopyTransparentCell "C2:J26"
End Sub註：如果找不到物件的話。把 工作表1 和 工作表2 改成 Worksheets("工作表1") 和 Worksheets("工作表2")
...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div>

zbc231 發表於 2017-2-10 06:25 AM

本帖最後由 zbc231 於 2017-2-10 06:34 AM 編輯

tryit244178 發表於 2017-2-10 03:30 AM static/image/common/back.gif
用這個試試順便說明一下
offestColumn = i.column - 1
這個是你要貼到 工作表2 的位置
可能是我的工作表1在名字前還有個編號，
所以在offestColumn = i.column - 1中，
減 1 的話，就是貼到 B 欄；所以我才改成-2，
這樣才會貼到A欄。
接續前面的部分，改成B只要是要回傳名字，
若是A則是回傳號碼，這部分我是有修改過。
以上兩點均是我在敘述時跟實作不同之處，
讓你因此多費心，真是感到抱歉。
測試後，他還是把所有資料貼出，沒有篩選。
因此想問一下可以改成另一種寫法嗎？
我主要是要將Sheet1比對區C2:J26跟登錄區K2:V23作資料比對，
再將只出現一次的資料所有人名字(就是比對區有資料，登錄區沒有，表示沒繳交)回傳到Sheet2，
以便我能一眼就了解狀況。
格子變色只是方便繳交人了解是否繳交，
並不一定要依此為判斷依據。
這樣的話，該怎麼寫呢？
...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div><br><br><br><br><br><div></div>

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

本帖最後由 tryit244178 於 2017-2-11 04:19 AM 編輯

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

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

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

目前只想到這2種可能會造成比對結果全部不同
你想想看，你的環境下，還有什麼可能性
...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div>

zbc231 發表於 2017-2-11 03:21 AM

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

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

我終於找到問題了，
那便是大小寫。
比對區為A01，
但是輸入區為a01，
所以才會出現沒有相同數值的狀況。
為了解決此情形，
我參閱網路上的方法在sheet1內加入下列程式碼，Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Target = UCase(Target)
Application.EnableEvents = True
End Sub在登錄區輸入時，的確小寫會變成大寫，
但我啟動清除資料的巨集時，
便會跳出偵錯畫面說型態不符合，
然後下列句子反黃，Target = UCase(Target)清除資料的巨集如下，Sub click()
Workbooks("紀錄表.xls").Sheets("LIST").Range(Cells(2, 11), Cells(23, 22)).ClearContents
End Sub這兩個功能是哪裡相沖呢？
另外在sheet1還有一段程式碼如下，Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row = 24 Then Cells(2, Target.Column + 1).Select
End Sub
這段程式碼不知道是我為了什麼作用貼上的，
可以告訴我它的功用嗎？
以上兩個問題，非常感謝你一路的回答。
...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div>

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

本帖最後由 tryit244178 於 2017-2-11 06:36 AM 編輯

因為一次清除了很多儲存格
但轉大寫的函式，一次只能轉一個儲存格，所以會產生錯誤
把最上面的程序改為Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Range
   
    Application.EnableEvents = False
    For Each i In Target
        If Not i = "" Then
            i = UCase(i)
        End If
    Next i
    Application.EnableEvents = True
End Sub
UCase() 是小寫轉大寫的函式
https://msdn.microsoft.com/zh-tw/library/53e2ew8a(v=vs.90).aspx

最後這段程序…看起來似乎是點到第24行的時候會跳到下一欄的第2行
大概是懶得換行吧XDPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Row = 24 Then Cells(2, Target.column + 1).Select  '懶得換行
End Sub
你可以像這樣為程序註解，『'』(冒號右邊那顆鍵)
...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div>

zbc231 發表於 2017-2-11 07:04 AM

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


終於完成了，
最後那段程序是我之前要讓他自動換行加的，
但是因為也是找資料來的，
所以就忘了。
最近三份excel都是麻煩你幫忙解決，
真是非常感謝你的指導。...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div>