填充底色问题

小星光

填充底色问题

taller

1. Option Explicit
   
2. Sub Demo()
   
3.     Dim objDic As Object, rngData As Range
   
4.     Dim i As Long, sKey
   
5.     Dim arrData
   
6.     Set objDic = CreateObject("scripting.dictionary")
   
7.     Set rngData = Range("F1", Cells(Rows.Count, "F").End(xlUp))
   
8.     arrData = rngData.Value
   
9.     For i = 3 To UBound(arrData)
   
10.         sKey = arrData(i, 1)
    
11.         If Len(sKey) > 0 Then
    
12.         If objDic.exists(sKey) Then
    
13.             Set objDic(sKey) = Union(Cells(i, "AL"), objDic(sKey))
    
14.         Else
    
15.             Set objDic(sKey) = Cells(i, "AL")
    
16.         End If
    
17.         End If
    
18.     Next i
    
19.     For Each sKey In objDic.keys
    
20.         With objDic(sKey)
    
21.             If .Cells.Count > 1 Then
    
22.             .Merge
    
23.             .Interior.Color = 10213316
    
24.             .Borders.LineStyle = Excel.xlContinuous
    
25.             With .Offset(, 2).Resize(.Cells.Count)
    
26.                 .Merge
    
27.                 .Interior.Color = 10213316
    
28.                 .Borders.LineStyle = Excel.xlContinuous
    
29.             End With
    
30.             End If
    
31.         End With
    
32.     Next
    
33. End Sub
    

复制代码

小星光

taller 发表于 2024-5-12 02:19

taller大师：谢谢您

Qs18

Sub test()
Dim r As Range, rng As Range
Set rng = Range("F1", Cells(Rows.Count, "F").End(xlUp))
For Each r In rng
    If r <> "" Then
    r.Offset(0, 32).Interior.Color = 10213316
    r.Offset(0, 34).Interior.Color = 10213316
    End If
Next
End Sub

Qs18

试一下。。。

小星光

Qs18 发表于 2024-5-12 07:43
试一下。。。

Qs18大师：谢谢您！