[已解决]求代码实现相差1单元格填充颜色

天上的云pc

求代码实现相差1单元格填充颜色

最佳答案

月排行榜 / 总排行榜

gufengaoyue

2016-8-12 18:25

1. Sub XX()
   
2. Dim arr, r%, c%, b%, R1 As Range, R2 As Range
   
3. r = 9: c = 2: arr = [B9:BG12]
   
4. [B9:BG12].Interior.Color = xlNone
   
5. For b = 1 To UBound(arr, 2)
   
6.     If Abs(arr(1, b) - arr(2, b)) = 1 And Abs(arr(3, b) - arr(4, b)) = 1 Then
   
7.         If arr(1, b) > arr(2, b) Then
   
8.             If R1 Is Nothing Then Set R1 = Cells(r, b + c - 1) Else Set R1 = Union(R1, Cells(r, b + c - 1))
   
9.             If R2 Is Nothing Then Set R2 = Cells(r + 1, b + c - 1) Else Set R2 = Union(R2, Cells(r + 1, b + c - 1))
   
10.         Else
    
11.             If R2 Is Nothing Then Set R2 = Cells(r, b + c - 1) Else Set R2 = Union(R2, Cells(r, b + c - 1))
    
12.             If R1 Is Nothing Then Set R1 = Cells(r + 1, b + c - 1) Else Set R1 = Union(R1, Cells(r + 1, b + c - 1))
    
13.         End If
    
14.         If arr(3, b) > arr(4, b) Then
    
15.             If R1 Is Nothing Then Set R1 = Cells(r + 2, b + c - 1) Else Set R1 = Union(R1, Cells(r + 2, b + c - 1))
    
16.             If R2 Is Nothing Then Set R2 = Cells(r + 3, b + c - 1) Else Set R2 = Union(R2, Cells(r + 3, b + c - 1))
    
17.         Else
    
18.             If R2 Is Nothing Then Set R2 = Cells(r + 2, b + c - 1) Else Set R2 = Union(R2, Cells(r + 2, b + c - 1))
    
19.             If R1 Is Nothing Then Set R1 = Cells(r + 3, b + c - 1) Else Set R1 = Union(R1, Cells(r + 3, b + c - 1))
    
20.         End If
    
21.     End If
    
22. Next
    
23. R1.Interior.Color = vbGreen
    
24. R2.Interior.Color = vbRed
    
25. Set R1 = Nothing: Set R2 = Nothing
    
26. End Sub

复制代码

跳转到最佳答案楼层

baksy

附件

天上的云pc

你好老师。要VBA代码的。

gufengaoyue

供参考

1. Sub XX()
   
2. '''先选中数据区域，再执行代码'''
   
3. If Selection.Rows.Count <> 4 Then Exit Sub
   
4. Dim Rng As Range, arr, r%, c%, b%, R1 As Range, R2 As Range
   
5. r = Selection(1).Row: c = Selection(1).Column: arr = Selection
   
6. Selection.Interior.Color = xlNone
   
7. For b = 1 To UBound(arr, 2)
   
8.     If Abs(arr(1, b) - arr(2, b)) = 1 And Abs(arr(3, b) - arr(4, b)) = 1 Then
   
9.         If arr(1, b) > arr(2, b) Then
   
10.             If R1 Is Nothing Then Set R1 = Cells(r, b + c - 1) Else Set R1 = Union(R1, Cells(r, b + c - 1))
    
11.             If R2 Is Nothing Then Set R2 = Cells(r + 1, b + c - 1) Else Set R2 = Union(R2, Cells(r + 1, b + c - 1))
    
12.         Else
    
13.             If R2 Is Nothing Then Set R2 = Cells(r, b + c - 1) Else Set R2 = Union(R2, Cells(r, b + c - 1))
    
14.             If R1 Is Nothing Then Set R1 = Cells(r + 1, b + c - 1) Else Set R1 = Union(R1, Cells(r + 1, b + c - 1))
    
15.         End If
    
16.         If arr(3, b) > arr(4, b) Then
    
17.             If R1 Is Nothing Then Set R1 = Cells(r + 2, b + c - 1) Else Set R1 = Union(R1, Cells(r + 2, b + c - 1))
    
18.             If R2 Is Nothing Then Set R2 = Cells(r + 3, b + c - 1) Else Set R2 = Union(R2, Cells(r + 3, b + c - 1))
    
19.         Else
    
20.             If R2 Is Nothing Then Set R2 = Cells(r + 2, b + c - 1) Else Set R2 = Union(R2, Cells(r + 2, b + c - 1))
    
21.             If R1 Is Nothing Then Set R1 = Cells(r + 3, b + c - 1) Else Set R1 = Union(R1, Cells(r + 3, b + c - 1))
    
22.         End If
    
23.     End If
    
24. Next
    
25. R1.Interior.Color = vbGreen
    
26. R2.Interior.Color = vbRed
    
27. Set R1 = Nothing: Set R2 = Nothing
    
28. End Sub

复制代码

天上的云pc

gufengaoyue 发表于 2016-8-12 18:13
供参考

可否固定数据区域范围，不用先选取。

gufengaoyue

1. Sub XX()
   
2. Dim arr, r%, c%, b%, R1 As Range, R2 As Range
   
3. r = 9: c = 2: arr = [B9:BG12]
   
4. [B9:BG12].Interior.Color = xlNone
   
5. For b = 1 To UBound(arr, 2)
   
6.     If Abs(arr(1, b) - arr(2, b)) = 1 And Abs(arr(3, b) - arr(4, b)) = 1 Then
   
7.         If arr(1, b) > arr(2, b) Then
   
8.             If R1 Is Nothing Then Set R1 = Cells(r, b + c - 1) Else Set R1 = Union(R1, Cells(r, b + c - 1))
   
9.             If R2 Is Nothing Then Set R2 = Cells(r + 1, b + c - 1) Else Set R2 = Union(R2, Cells(r + 1, b + c - 1))
   
10.         Else
    
11.             If R2 Is Nothing Then Set R2 = Cells(r, b + c - 1) Else Set R2 = Union(R2, Cells(r, b + c - 1))
    
12.             If R1 Is Nothing Then Set R1 = Cells(r + 1, b + c - 1) Else Set R1 = Union(R1, Cells(r + 1, b + c - 1))
    
13.         End If
    
14.         If arr(3, b) > arr(4, b) Then
    
15.             If R1 Is Nothing Then Set R1 = Cells(r + 2, b + c - 1) Else Set R1 = Union(R1, Cells(r + 2, b + c - 1))
    
16.             If R2 Is Nothing Then Set R2 = Cells(r + 3, b + c - 1) Else Set R2 = Union(R2, Cells(r + 3, b + c - 1))
    
17.         Else
    
18.             If R2 Is Nothing Then Set R2 = Cells(r + 2, b + c - 1) Else Set R2 = Union(R2, Cells(r + 2, b + c - 1))
    
19.             If R1 Is Nothing Then Set R1 = Cells(r + 3, b + c - 1) Else Set R1 = Union(R1, Cells(r + 3, b + c - 1))
    
20.         End If
    
21.     End If
    
22. Next
    
23. R1.Interior.Color = vbGreen
    
24. R2.Interior.Color = vbRed
    
25. Set R1 = Nothing: Set R2 = Nothing
    
26. End Sub

复制代码

天上的云pc

gufengaoyue 发表于 2016-8-12 18:25

效果还是不对哦  

gufengaoyue

天上的云pc 发表于 2016-8-12 18:47
效果还是不对哦

见6楼。已改。

luhao1990

Sub test()
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim y As Integer
x = Cells(9, 256).End(xlToLeft).Column
Cells.Interior.ColorIndex = xlNone

For i = 2 To x

If Cells(9, i) - Cells(10, i) = 1 Then

Cells(9, i).Interior.ColorIndex = 3
Cells(10, i).Interior.ColorIndex = 4
End If

If Cells(10, i) - Cells(9, i) = 1 Then

Cells(9, i).Interior.ColorIndex = 4
Cells(10, i).Interior.ColorIndex = 3
End If
If Cells(11, i) - Cells(12, i) = 1 Then
Cells(11, i).Interior.ColorIndex = 3
Cells(12, i).Interior.ColorIndex = 4
End If
If Cells(12, i) - Cells(11, i) = 1 Then
Cells(12, i).Interior.ColorIndex = 3
Cells(11, i).Interior.ColorIndex = 4
End If
Next



End Sub