返回列表 上一主題 發帖

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

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

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
新手上路,請多包涵。

Hello, 軒云熊大

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

TOP

回復 14# 劉大胃

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

0412.rar (20.54 KB)

TOP

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

回復 14# 劉大胃

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

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

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

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

  30. For Each D In xD
  31. SP = Split(xD(D), " ")
  32.     If UBound(SP) < 1 Then
  33.         G = G & "," & Cells(xD(D), 1).Row
  34.     End If
  35. Next D

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

  37. Application.ScreenUpdating = True
  38. End Sub
複製代碼
[attach]33190[/attach]

0412.rar (7.51 KB)

TOP

Hello, 軒云熊大

抱歉! 我未在您的附件裡, 看到任何的程式段. Thanks ~
新手上路,請多包涵。

TOP

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

回復 10# 劉大胃

有空幫我看看這樣是不是你要的結果  謝謝
0411.rar (6.3 KB)

TOP

Program example.


FntColorChk.rar (15.64 KB)
新手上路,請多包涵。

TOP

Hello, 軒云熊大

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

FntColorChk.rar (15.64 KB)
新手上路,請多包涵。

TOP

Hello, 軒云熊大

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

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

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

        靜思自在 : 要批評別人時,先想想自己是否完美無缺。
返回列表 上一主題