返回列表 上一主題 發帖

[發問] 關於欄位字體顏色差異的判斷?

[發問] 關於欄位字體顏色差異的判斷?

Hello, 各位大大

   抱歉, 公司無法上傳附件與圖片!!
   如下程式段所示, 我有二個欄位, 需要判別其內容字體有無變更顏色, 但每一個字都去判斷的話, 會很容易造成系統執行的時間變長.
   但~亦如程式段中的註解, 將其Enable 的話, 卻只能判斷整個欄位的字體顏色,
   所以不知有何方式可以先行做欄位對欄位的顏色判別, 再進而對顏色有異的欄位, 再進行字與字的確認?

Thanks ~




Sub FntColorChk()

    Dim r As Integer, i As Integer, j As Integer
    Dim f As Boolean
    Dim d1 As Date, d2 As Date


    r = ActiveSheet.Cells(65536, 2).End(xlUp).Row
    Range("E2:H1000").ClearContents
    d1 = Now()
   
    Application.ScreenUpdating = False
   
    For i = 2 To r Step 1
        f = True
        d2 = Now()
        DoEvents
''        If Cells(i, 2).Font.Color <> Cells(i, 3).Font.Color Or _
''           Cells(i, 2).Font.ColorIndex <> Cells(i, 3).Font.ColorIndex Then

           For j = 1 To Len(Cells(i, 2).Value) Step 1
               If Cells(i, 2).Characters(Start:=j, Length:=1).Font.ColorIndex <> Cells(i, 3).Characters(Start:=j, Length:=1).Font.ColorIndex Then
                  f = False
                  Exit For
               End If
           Next j
''        End If
        Cells(i, 6).Value = Format((Now() - d2) * 24 * 60 * 60, "0.000")
        If f = False Then
           Cells(i, 5).Value = "Change"
        End If
        Cells(i, 7).Value = DatePart("s", Now() - d1)
    Next i
   
    Application.ScreenUpdating = True
    MsgBox "Finish ..."
   
End Sub
新手上路,請多包涵。

隨意窩 "EXCEL迷"  blog  或 http://blog.xuite.net/hcm19522/twblog[img][/img]
已收集7000篇 EXCEL函數

TOP

回復 2# hcm19522
Hello, hcm19522大

這個連結是針對欄位的底色做判別.
而我的問題是字體顏色, 而且是同一欄位裡有2種以上不同顏色時,
如果另一欄位的顏色位置相同的話, 亦不需做逐字的顏色比對.

Thanks ~
新手上路,請多包涵。

TOP

回復 3# 劉大胃

有空試試看是不是你要的結果感謝
  1. Public Sub 顏色比對練習()

  2. For X = 1 To 2
  3.     For Y = 3 To 7
  4.     If Cells(X, 1).Interior.Color = Cells(Y, 1).Interior.Color Then
  5.         If Cells(X, 1).Font.Color = Cells(Y, 1).Font.Color Then
  6.            Cells(Y, 1).Interior.Color = RGB(160, 250, 120)
  7.         End If
  8.     End If
  9.     Next Y
  10. Next X

  11. End Sub
複製代碼
0408.rar (10.42 KB)

TOP

回復 4# 軒云熊
Hello, 軒云熊大

謝謝你的回覆,但仍不是我所需要的問題。
因你的方式,和我註解的程式段是一樣的。
這個方式只能判斷同一個cell裡,其字顏色皆都是一樣的情況。如果同一個cell裡,有二種以上的顏色就無法判別了!而使用bit by bit check, 很容易造成下一個row的延遲。Anyway, 再請大大協助,可有方法?Thanks.
新手上路,請多包涵。

TOP

本帖最後由 劉大胃 於 2021-4-9 09:28 編輯

總於將附圖片放上來了!
  1. [img][/img]
複製代碼
[attach]33175[/attach]
新手上路,請多包涵。

TOP

[attach]33175[/attach]
新手上路,請多包涵。

TOP

好像還是無法附件圖片, 按確認之後, 網頁就變得一片空白了!
後續再看, 就只剩一串附件代碼.....>_<......
新手上路,請多包涵。

TOP

本帖最後由 軒云熊 於 2021-4-10 23:06 編輯

回復 8# 劉大胃
有空幫我試試看 這樣行不行 感謝
  1. Public Sub 判斷顏色練習()

  2. Set xD = CreateObject("Scripting.Dictionary")

  3. For I = 1 To 4
  4.     For Y = 1 To Len(Cells(I, 1))
  5.         E = E & Cells(I, 1).Characters(Y, 1).Font.ColorIndex
  6.     Next Y
  7.     xD(E) = Trim(xD(E) & " " & I)
  8.     E = ""
  9. Next I

  10. For Each D In xD
  11.     SP = Split(xD(D), " ")
  12.     If UBound(SP) < 1 Then
  13.         Cells(xD(D), 1).Select
  14.     End If
  15. Next D

  16. End Sub
複製代碼
0410.rar (6.31 KB)

TOP

Hello, 軒云熊大

謝謝您的幫忙.
但這個方式也只是記錄一個cell裡的字體何位置的顏色有異而已,
我要的只二個cell裡, 相同的字數, 但某些位置的字體顏色, 二個cell是有變異的.
有什麼方式可以不需要一個一個字去, 二個cell的比對?
而是可以先做二個cell的顏色是否一致? 在不一致時, 才進行字頻位置的尋找,
因為只要一進入到Characters的比對, 很容易造成系統執行變慢.
Thanks ~

ps. 圖片要怎麼附加?  因為每次上傳完圖片, 按確認之後, 網頁就變得一片空白了!
後續再看, 就只剩一串附件代碼!!
新手上路,請多包涵。

TOP

        靜思自在 : 為人處世要小心細心,但不要「小心眼」。
返回列表 上一主題