- 帖子
- 254
- 主題
- 6
- 精華
- 0
- 積分
- 310
- 點名
- 0
- 作業系統
- W10
- 軟體版本
- Excel 2016
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2019-6-16
- 最後登錄
- 2024-9-23
|
15#
發表於 2021-4-12 21:26
| 只看該作者
本帖最後由 軒云熊 於 2021-4-12 21:29 編輯
回復 14# 劉大胃
抱歉 檔案沒有存到檔 >"< ...
有空幫我試試看 這個結果是不是你要的
但有一個很大的問題 如果檔案很大 會跑非常慢..因為我的迴圈太多了 而且串聯太多次..
不知道如果用 物件加字典 會不會比較快 或著 有更好的寫法 看看有沒有大大可以幫忙 感謝- Public Sub 判斷顏色練習0412()
- Application.ScreenUpdating = False
- Set xD = CreateObject("Scripting.Dictionary")
- For I = 1 To Cells(1, 1).End(4).Row
- E = Cells(I, 1)
- xD(E) = Trim(xD(E) & " " & I) & E
- Next I
- E = ""
- For Each D In xD
- SP = Split(xD(D), " ")
- If UBound(SP) = 0 Then xD.Remove (D): GoTo A01
- For Each S In SP
- If UBound(SP) > 0 Then
- If E <> "" Then xD(E) = Trim(xD(E) & " " & Mid(S, 1, 1))
- E = ""
- End If
- Next S
- A01: Next D
- For Each D In xD
- SP = Split(xD(D), " ")
- For Each S In SP
- For Y = 1 To Len(Cells(Mid(S, 1, 1), 1))
- E = E & Cells(Mid(S, 1, 1), 1).Characters(Y, 1).Font.ColorIndex
- Next Y
- If E <> "" Then xD(E) = Trim(xD(E) & " " & Mid(S, 1, 1))
- If F = 0 Then xD.Remove (D): F = 1
- E = ""
- Next S
- Next D
- For Each D In xD
- SP = Split(xD(D), " ")
- If UBound(SP) < 1 Then
- G = G & "," & Cells(xD(D), 1).Row
- End If
- Next D
- MsgBox Mid(G, 2) & "列顏色不相同"
- Application.ScreenUpdating = True
- End Sub
|
-
-
0412.rar
(7.51 KB)
|
