Board logo

標題: [發問] 關於欄位字體顏色差異的判斷? [打印本頁]
作者: 劉大胃    時間: 2021-4-8 11:35     標題: 關於欄位字體顏色差異的判斷?

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
作者: hcm19522    時間: 2021-4-8 13:58

https://blog.xuite.net/hcm19522/twblog/205029860
作者: 劉大胃    時間: 2021-4-8 16:21

回復 2# hcm19522
Hello, hcm19522大

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

Thanks ~
作者: 軒云熊    時間: 2021-4-8 19:12

回復 3# 劉大胃

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

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

  13. End Sub
複製代碼
[attach]33173[/attach]
作者: 劉大胃    時間: 2021-4-9 09:03

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

謝謝你的回覆，但仍不是我所需要的問題。
因你的方式，和我註解的程式段是一樣的。
這個方式只能判斷同一個cell裡，其字顏色皆都是一樣的情況。如果同一個cell裡，有二種以上的顏色就無法判別了！而使用bit by bit check, 很容易造成下一個row的延遲。Anyway, 再請大大協助，可有方法？Thanks.
作者: 劉大胃    時間: 2021-4-9 09:22

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

總於將附圖片放上來了！
  1. [img][/img]
複製代碼
[attach]33175[/attach]
作者: 劉大胃    時間: 2021-4-9 09:50

[attach]33175[/attach]
作者: 劉大胃    時間: 2021-4-9 10:18

好像還是無法附件圖片, 按確認之後, 網頁就變得一片空白了!
後續再看, 就只剩一串附件代碼.....>_<......
作者: 軒云熊    時間: 2021-4-10 23:05

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

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

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

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

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

  20. End Sub
複製代碼
[attach]33182[/attach]
作者: 劉大胃    時間: 2021-4-11 11:20

Hello, 軒云熊大

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

ps. 圖片要怎麼附加?  因為每次上傳完圖片, 按確認之後, 網頁就變得一片空白了!
後續再看, 就只剩一串附件代碼!!
作者: 劉大胃    時間: 2021-4-11 22:18

Hello, 軒云熊大

再看看能否上傳?
如附件所示, 二個cell的字體顏色比較,
可有什麼指令可以不做一個字一個字的顏色比對?
因為不知為麼什麼, 如果做一個字一個字的比對,
很容易造成下一個row的系統執行時間變慢!!

[attach]33183[/attach]
作者: 劉大胃    時間: 2021-4-11 22:31

Program example.


[attach]33184[/attach]
作者: 軒云熊    時間: 2021-4-11 23:44

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

回復 10# 劉大胃

有空幫我看看這樣是不是你要的結果  謝謝
[attach]33188[/attach]
作者: 劉大胃    時間: 2021-4-12 10:06

Hello, 軒云熊大

抱歉! 我未在您的附件裡, 看到任何的程式段. Thanks ~
作者: 軒云熊    時間: 2021-4-12 21:26

本帖最後由 軒云熊 於 2021-4-12 21:29 編輯

回復 14# 劉大胃

抱歉 檔案沒有存到檔 >"< ...
有空幫我試試看 這個結果是不是你要的  
但有一個很大的問題  如果檔案很大 會跑非常慢..因為我的迴圈太多了 而且串聯太多次..
不知道如果用 物件加字典 會不會比較快 或著 有更好的寫法 看看有沒有大大可以幫忙  感謝
  1. Public Sub 判斷顏色練習0412()
  2. Application.ScreenUpdating = False
  3. Set xD = CreateObject("Scripting.Dictionary")

  5. For I = 1 To Cells(1, 1).End(4).Row
  6. E = Cells(I, 1)
  7.     xD(E) = Trim(xD(E) & " " & I) & E
  8. Next I
  9. E = ""

  11. For Each D In xD
  12.     SP = Split(xD(D), " ")
  13.     If UBound(SP) = 0 Then xD.Remove (D): GoTo A01
  14.     For Each S In SP
  15.         If UBound(SP) > 0 Then
  16.             If E <> "" Then xD(E) = Trim(xD(E) & " " & Mid(S, 1, 1))
  17.             E = ""
  18.         End If
  19.     Next S
  20. A01: Next D

  22. For Each D In xD
  23. SP = Split(xD(D), " ")
  24.     For Each S In SP
  25.         For Y = 1 To Len(Cells(Mid(S, 1, 1), 1))
  26.             E = E & Cells(Mid(S, 1, 1), 1).Characters(Y, 1).Font.ColorIndex
  27.         Next Y
  28.         If E <> "" Then xD(E) = Trim(xD(E) & " " & Mid(S, 1, 1))
  29.         If F = 0 Then xD.Remove (D): F = 1
  30.         E = ""
  31.     Next S
  32. Next D

  34. For Each D In xD
  35. SP = Split(xD(D), " ")
  36.     If UBound(SP) < 1 Then
  37.         G = G & "," & Cells(xD(D), 1).Row
  38.     End If
  39. Next D

  41. MsgBox Mid(G, 2) & "列顏色不相同"

  43. Application.ScreenUpdating = True
  44. End Sub
複製代碼
[attach]33190[/attach]
作者: 軒云熊    時間: 2021-4-12 23:41

回復 14# 劉大胃

剛才發現 檔案沒上傳好  抱歉 再傳一次

[attach]33195[/attach]
作者: 劉大胃    時間: 2021-4-13 10:41

Hello, 軒云熊大

謝謝您的幫忙!!
因為我的資料約在1000行左右,
發現只要系統一進入到Character 的字元比對時,
就會造成執行速度的變慢!!
而且發問的問題也是意在縮減系統執行時間...
Anyway, 還是謝謝您的大力幫忙.



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