[已解决]按条件填充颜色

meet10010

按条件填充颜色

最佳答案

月排行榜 / 总排行榜

dsmch

2015-1-22 15:08

1. Sub Macro1()
   
2. Dim arr, brr(1 To 65000, 1 To 1), w(9)
   
3. arr = [a22:iv24]
   
4. n = 100 'UBound(arr, 2)
   
5. For a = 2 To n - 3
   
6.     For b = a + 1 To n - 2
   
7.         For c = b + 1 To n - 1
   
8.             For d = c + 1 To n
   
9.                 w(arr(1, a)) = arr(1, a)
   
10.                 w(arr(1, b)) = arr(1, b)
    
11.                 w(arr(1, c)) = arr(1, c)
    
12.                 w(arr(1, d)) = arr(1, d)
    
13.                 w(arr(3, a)) = arr(3, a)
    
14.                 w(arr(3, b)) = arr(3, b)
    
15.                 w(arr(3, c)) = arr(3, c)
    
16.                 w(arr(3, d)) = arr(3, d)
    
17.                 If Len(Join(w, "")) = 8 Then s = s + 1: brr(s, 1) = a & "," & b & "," & c & "," & d
    
18.                 Erase w
    
19.                 If s > 60000 Then GoTo line100
    
20.             Next
    
21.         Next
    
22.     Next
    
23. Next
    
24. line100:
    
25. '结果代表符合数据所在的列
    
26. Range("a26").Resize(s) = brr
    
27. End Sub

复制代码

跳转到最佳答案楼层

dsmch

如果结果过多，点击按钮一次实现一次结果，相信楼主会没有这个耐心的

meet10010

dsmch 发表于 2015-1-21 16:33
如果结果过多，点击按钮一次实现一次结果，相信楼主会没有这个耐心的

只要能实现，有的。查找到的4列不要重复太多则更好。

芐雨

这样看行不

1. Sub t()
   
2.     Dim rg As Range, rng As Range, rgg As Range
   
3.     Dim lc&, arrRg As Range, dic As Object
   
4.     lc = Cells(22, Columns.Count).End(1).Column  '最大列数
   
5.     Set arrRg = Union([A22].Resize(, lc), [A24].Resize(, lc))
   
6.     arrRg.Interior.Pattern = xlNone    '无填充色
   
7.     On Error Resume Next
   
8.     Set rng = Application.InputBox("请选择四个不同列的单元格！按ctrl键多选。", , , , , , , 8)
   
9.     If rng.Count <> 4 Then MsgBox "请选择四个不同列的单元格": Exit Sub
   
10.     For Each rg In rng
    
11.         If rgg Is Nothing Then
    
12.             Set rgg = rg.EntireColumn  '单元格的整列
    
13.         Else
    
14.             Set rgg = Union(rgg, rg.EntireColumn)
    
15.         End If
    
16.     Next
    
17.     Set rgg = Application.Intersect(rgg, arrRg)  '行列单元格交集，应该等到8个单元格
    
18.     If rgg.Count <> 8 Then MsgBox "请选择四个不同列的单元格": Exit Sub
    
19.     Set dic = CreateObject("scripting.dictionary")
    
20.     For Each rg In rgg            '遍历单元格
    
21.         dic(rg.Value) = ""        '记入字典
    
22.     Next
    
23.     If dic.Count = 8 Then rgg.Interior.Color = 255 '字典数为8时执行填充
    
24. End Sub
    

复制代码

dsmch

1. Sub Macro1()
   
2. Dim arr, brr(1 To 60000, 1 To 1), w(9)
   
3. arr = [a22:iv24]
   
4. n = 100 'UBound(arr, 2)
   
5. For a = 2 To n - 3
   
6.     For b = a + 1 To n - 2
   
7.         For c = b + 1 To n - 1
   
8.             For d = c + 1 To n
   
9.                 w(arr(1, a)) = arr(1, a)
   
10.                 w(arr(1, b)) = arr(1, b)
    
11.                 w(arr(1, c)) = arr(1, c)
    
12.                 w(arr(1, d)) = arr(1, d)
    
13.                 w(arr(3, a)) = arr(3, a)
    
14.                 w(arr(3, b)) = arr(3, b)
    
15.                 w(arr(3, c)) = arr(3, c)
    
16.                 w(arr(3, d)) = arr(3, d)
    
17.             Next
    
18.             If Len(Join(w, "")) = 8 Then s = s + 1: brr(s, 1) = a & "," & b & "," & c & "," & d
    
19.             Erase w
    
20.         Next
    
21.     Next
    
22. Next
    
23. '结果代表符合数据所在的列
    
24. Range("a26").Resize(s) = brr
    
25. End Sub

复制代码

meet10010

dsmch 发表于 2015-1-22 10:29

非常感谢老师的代码，很强大，安排结果也很合理。

但是求得结果不对，求得的4列中，有的不是8个不同的数字。麻烦老师再看看。

dsmch

1. Sub Macro1()
   
2. Dim arr, brr(1 To 65000, 1 To 1), w(9)
   
3. arr = [a22:iv24]
   
4. n = 100 'UBound(arr, 2)
   
5. For a = 2 To n - 3
   
6.     For b = a + 1 To n - 2
   
7.         For c = b + 1 To n - 1
   
8.             For d = c + 1 To n
   
9.                 w(arr(1, a)) = arr(1, a)
   
10.                 w(arr(1, b)) = arr(1, b)
    
11.                 w(arr(1, c)) = arr(1, c)
    
12.                 w(arr(1, d)) = arr(1, d)
    
13.                 w(arr(3, a)) = arr(3, a)
    
14.                 w(arr(3, b)) = arr(3, b)
    
15.                 w(arr(3, c)) = arr(3, c)
    
16.                 w(arr(3, d)) = arr(3, d)
    
17.                 If Len(Join(w, "")) = 8 Then s = s + 1: brr(s, 1) = a & "," & b & "," & c & "," & d
    
18.                 Erase w
    
19.                 If s > 60000 Then GoTo line100
    
20.             Next
    
21.         Next
    
22.     Next
    
23. Next
    
24. line100:
    
25. '结果代表符合数据所在的列
    
26. Range("a26").Resize(s) = brr
    
27. End Sub

复制代码