|
供参考- Sub XX()
- '''先选中数据区域,再执行代码'''
- If Selection.Rows.Count <> 4 Then Exit Sub
- Dim Rng As Range, arr, r%, c%, b%, R1 As Range, R2 As Range
- r = Selection(1).Row: c = Selection(1).Column: arr = Selection
- Selection.Interior.Color = xlNone
- For b = 1 To UBound(arr, 2)
- If Abs(arr(1, b) - arr(2, b)) = 1 And Abs(arr(3, b) - arr(4, b)) = 1 Then
- If arr(1, b) > arr(2, b) Then
- If R1 Is Nothing Then Set R1 = Cells(r, b + c - 1) Else Set R1 = Union(R1, Cells(r, b + c - 1))
- If R2 Is Nothing Then Set R2 = Cells(r + 1, b + c - 1) Else Set R2 = Union(R2, Cells(r + 1, b + c - 1))
- Else
- If R2 Is Nothing Then Set R2 = Cells(r, b + c - 1) Else Set R2 = Union(R2, Cells(r, b + c - 1))
- If R1 Is Nothing Then Set R1 = Cells(r + 1, b + c - 1) Else Set R1 = Union(R1, Cells(r + 1, b + c - 1))
- End If
- If arr(3, b) > arr(4, b) Then
- If R1 Is Nothing Then Set R1 = Cells(r + 2, b + c - 1) Else Set R1 = Union(R1, Cells(r + 2, b + c - 1))
- If R2 Is Nothing Then Set R2 = Cells(r + 3, b + c - 1) Else Set R2 = Union(R2, Cells(r + 3, b + c - 1))
- Else
- If R2 Is Nothing Then Set R2 = Cells(r + 2, b + c - 1) Else Set R2 = Union(R2, Cells(r + 2, b + c - 1))
- If R1 Is Nothing Then Set R1 = Cells(r + 3, b + c - 1) Else Set R1 = Union(R1, Cells(r + 3, b + c - 1))
- End If
- End If
- Next
- R1.Interior.Color = vbGreen
- R2.Interior.Color = vbRed
- Set R1 = Nothing: Set R2 = Nothing
- End Sub
复制代码 |
|