用VBA实现垂直一相连和斜对角线 优化再优化

laoau138

用VBA实现垂直一相连和斜对角线  优化再优化

laoau138

还有什么好方法，请发贴，高手

Sub 按钮1_Click()
    With [a3:t12]
        .ClearFormats
        For i = 1 To .Columns.Count
            For j = 1 To .Rows.Count
                If .Cells(j, i) <> "" Then .Cells(j, i).Interior.Color = vbGreen
            Next
        Next
        For i = 1 To .Columns.Count
            For j = 1 To .Rows.Count
                If .Cells(j, i) <> "" Then
                    If .Cells(j - 1, i) = "" Then
                        x = 1
                        While .Cells(j, i).Offset(x, 0) <> ""
                            x = x + 1
                        Wend
                        If x >= 5 Then
                            .Cells(j, i).Resize(x).Interior.Color = vbRed
                        ElseIf x = 4 Then
                            .Cells(j, i).Resize(x).Interior.Color = vbYellow
                        End If
                    End If
                    If i = 1 Then
                        GoTo xxx
                    ElseIf .Cells(j + 1, i - 1) = "" Then
xxx:
                        x = 1
                        While .Cells(j, i).Offset(-x, x) <> ""
                            x = x + 1
                        Wend
                        c = IIf(x >= 5, vbRed, vbYellow)
                        If x >= 4 Then
                            For k = 0 To x - 1
                                .Cells(j, i).Offset(-k, k).Interior.Color = c
                            Next
                        End If
                    End If
                End If
            Next
        Next
    End With
End Sub

today0427

laoau138 发表于 2016-10-7 22:45
还有什么好方法，请发贴，高手

Sub 按钮1_Click()

学习了！你都是哪儿找来的这些题目啊，居然还自带答案！真是很好的学习资料！

laoau138

today0427 发表于 2016-10-7 23:19
学习了！你都是哪儿找来的这些题目啊，居然还自带答案！真是很好的学习资料！

一楼题目来自EH

两个答案找人写

grf1973

1. Sub grf()
   
2.     Dim Rng As Range
   
3.     Range("a3:t12").Interior.ColorIndex = 0
   
4.     For Each Rng In Range("a3:t12")
   
5.         If Len(Rng) > 0 Then Rng.Interior.ColorIndex = 4
   
6.     Next
   
7.     For xs = 4 To 5   '步长选4及5就行，超过部分会由下一个Rng补上
   
8.         For Each Rng In Range("a3:t12")
   
9.             If Len(Rng) > 0 Then Call 相等或连续(Rng, xs)
   
10.         Next
    
11.     Next
    
12. End Sub
    
13. 
    
14. Sub 相等或连续(Rng As Range, xs)     '判断以Rng为当前位置，八个方向xs个单位内是否相等或连续
    
15.     Dim IsEq As Boolean
    
16.     On Error Resume Next     '容错，当方向出界
    
17.     If xs = 0 Then Exit Sub
    
18.     cl = IIf(xs = 4, 6, 3) '颜色(连续4格满足，填黄色，否则填红色）
    
19.     For rr = -1 To 1     '八个方向
    
20.         For cc = -1 To 1
    
21.             If rr = 0 And cc = 0 Then GoTo 100
    
22.             
    
23.             IsEq = True    '相同情况
    
24.             For j = 1 To xs - 1
    
25.                 If Rng.Offset(rr * j, cc * j) <> Rng Or Rng.Offset(rr * j, cc * j) = "" Then IsEq = False: Exit For
    
26.             Next
    
27.             If IsEq = True Then     '满足条件，填色
    
28.                 For j = 0 To xs - 1
    
29.                     Rng.Offset(rr * j, cc * j).Interior.ColorIndex = cl
    
30.                 Next
    
31.                 GoTo 100
    
32.             End If
    
33.             
    
34.             IsEq = True     '连续情况
    
35.             For j = 1 To xs - 1
    
36.                 If Rng.Offset(rr * j, cc * j) <> Rng.Offset(rr * (j - 1), cc * (j - 1)) + 1 Or Rng.Offset(rr * j, cc * j) = "" Then IsEq = False: Exit For
    
37.             Next
    
38.             If IsEq = True Then
    
39.                 For j = 0 To xs - 1
    
40.                     Rng.Offset(rr * j, cc * j).Interior.ColorIndex = cl
    
41.                 Next
    
42.             End If
    
43.             
    
44. 100:    Next
    
45.     Next
    
46. End Sub
    

复制代码

grf1973

请看附件。

grf1973

2楼代码只考虑了纵向，把横向的漏掉了。
原附件自带的代码只考虑了左到右，上到下，逆向的漏掉了。
5楼的考虑了八个方向。

laoau138

grf1973 发表于 2016-10-8 11:32
2楼代码只考虑了纵向，把横向的漏掉了。
原附件自带的代码只考虑了左到右，上到下，逆向的漏掉了。
5楼的 ...

这个不知道，题目是其他 人

laoau138

grf1973 发表于 2016-10-8 11:24

大侠这个如何做

VBA计算一行同时出现2个数的遗漏

http://www.excelpx.com/thread-424909-1-1.html

laoau138

today0427 发表于 2016-10-7 23:19
学习了！你都是哪儿找来的这些题目啊，居然还自带答案！真是很好的学习资料！

today  可以去可以了

VBA计算一行同时出现2个数的遗漏

http://www.excelpx.com/thread-424909-1-1.html