[發問] (已解決)如何同一區塊相同資料標顏色

freeffly

以前在一般區問過同樣問題
如何同一區塊相同資料標顏色
不過資料多的時候會發生excel當掉的感覺
不知道是不是持續運算的關係
如果改成用vba要如何寫?
A欄要做像D欄那樣的效果

Test.rar (11.36 KB)

下載次數: 10

2012-5-11 09:34

register313

回復 1# freeffly

A欄必須要排序

1. Sub xx()
   
2. Dim d As Object
   
3. Dim Rng As Range
   
4. Columns("A").Interior.ColorIndex = 0
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. For Each A In Range("A2:A" & [A65536].End(xlUp).Row)
   
7.   d(A.Value) = A.Value
   
8. Next
   
9. Ar = d.Items
   
10. For Each A In Range("A2:A" & [A65536].End(xlUp).Row)
    
11.   For R = 0 To d.Count Step 2
    
12.     If A = Ar(R) Then
    
13.       If Rng Is Nothing Then
    
14.         Set Rng = A
    
15.       Else
    
16.         Set Rng = Union(Rng, A)
    
17.       End If
    
18.     End If
    
19.   Next R
    
20. Next
    
21. Rng.Interior.ColorIndex = 6
    
22. End Sub

複製代碼

freeffly

回復 2# register313


    謝謝
   字典的對我來說還很難
   感覺比文言文還難

freeffly

回復 2# register313

    大大
    剛剛發現會有列數限制
   這各有辦法克服嗎
   太多好像會出現陣列超出範圍的問題









Book122.rar (9.17 KB)

下載次數: 3

2012-5-21 11:56

register313

回復 4# freeffly
不是列數限制
之前程式稍作修正

1. Sub xx()
   
2. Dim d As Object
   
3. Dim Rng As Range
   
4. Dim Ar
   
5. Columns("A").Interior.ColorIndex = 0
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. For Each A In Range("A2:A" & [A65536].End(xlUp).Row)
   
8.   d(A.Value) = A.Value
   
9. Next
   
10. Ar = d.Items
    
11. For Each A In Range("A2:A" & [A65536].End(xlUp).Row)
    
12.   For R = 1 To d.Count - 1 Step 2
    
13.       If A = Ar(R) Then
    
14.       If Rng Is Nothing Then
    
15.         Set Rng = A
    
16.       Else
    
17.         Set Rng = Union(Rng, A)
    
18.       End If
    
19.     End If
    
20.   Next R
    
21. Next
    
22. Rng.Interior.ColorIndex = 6
    
23. End Sub

複製代碼

freeffly

回復 5# register313


    大大請問第12行代碼的意思

   如果用原代碼 後面加-1也可行

1. For R = 0 To d.Count - 1 Step 2

複製代碼

或是原代碼1改為0也行

1. For R = 1 To d.Count  Step 2

複製代碼

大大新的代碼是這各 還有Dim Ar

1. For R = 1 To d.Count - 1 Step 2

複製代碼

作了之後標顏色區塊有點不一樣 可是會同樣效果
   也不會出現陣列超出範圍
   為什麼會有差異?

register313

回復 6# freeffly

說明詳見檔案
Test.rar (13.89 KB)

下載次數: 9

2012-5-21 15:24

freeffly

回復 7# register313


    謝謝大大
   for to step 這各之前沒用過
   看到附件才知道是count的數量是偶數或單數造成
   學習了

Andy2483

回復 1# freeffly


    謝謝論壇,謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,學習方案如下,請前輩參考,請各位前輩指教

執行前:

下載 (103.35 KB)

2023-4-10 15:46

執行結果:

下載 (105.77 KB)

2023-4-10 15:46

Option Explicit
Sub TEST()
Dim Brr, Y, i&, T$
Dim xR As Range, xU As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([A2], Cells(Rows.Count, "A").End(3)): Brr = xR
Set xU = [A1]
For i = 1 To UBound(Brr)
   T = Brr(i, 1)
   If Y(T) = "" Then Y(T) = Y.Count
   If Y(T) Mod 2 = 0 Then Set xU = Union(xU, Cells(i + 1, 1))
Next
[A:A].Interior.ColorIndex = xlNone
xU.Interior.ColorIndex = 6
Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub