[已解决]给单元格随机填充红色

excelpxfans001

给单元格随机填充红色

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-7 22:51

excelpxfans001 发表于 2016-6-7 22:42
从左至右的第一个填充红色的单元格。

1. Sub xx()
   
2.     Dim rng As Range, i&, dc As Object, c As Integer, x As Integer, y As Integer
   
3.     On Error Resume Next
   
4.     Set rng = Selection
   
5.     If Application.Count(rng) < 10 Then Exit Sub  '至少选择10个，需要与参数匹配
   
6.     If rng.Rows.Count > 1 Then Exit Sub
   
7.     c = rng.Columns.Count
   
8.     Set dc = CreateObject("scripting.dictionary")
   
9.     rng.Interior.ColorIndex = 0
   
10.     y = 2000
    
11.     With dc
    
12.         Do
    
13.             Randomize
    
14.             x = Int(Rnd * c + 1)
    
15.             If Not dc.Exists(x) Then
    
16.                 .Add x, ""
    
17.                 rng(1, x).Interior.Color = 192
    
18.                 If x < y Then y = x
    
19.             End If
    
20.         Loop Until .Count = 10  '在此修改参数
    
21.     End With
    
22.     rng(1, y).Select
    
23. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     Dim rng As Range, i&, dc As Object, c As Integer, x As Integer
   
3.     Set rng = Target
   
4.     If Application.Count(rng) < 10 Then Exit Sub  '至少选择10个，需要与参数匹配
   
5.     If rng.Rows.Count > 1 Then Exit Sub
   
6.     c = rng.Columns.Count
   
7.     Set dc = CreateObject("scripting.dictionary")
   
8.     On Error Resume Next
   
9.     With dc
   
10.         Do
    
11.             Randomize
    
12.             x = Int(Rnd * c + 1)
    
13.             If Not dc.Exists(x) Then
    
14.                 .Add x, ""
    
15.                 rng(1, x).Interior.Color = 192
    
16.             End If
    
17.         Loop Until .Count = 10  '在此修改参数
    
18.     End With
    
19. End Sub

复制代码

excelpxfans001

老司机带带我 发表于 2016-6-7 21:29

你好老师。
不需要自动的哦。要选取行区域后，运行代码，实现效果。

老司机带带我

excelpxfans001 发表于 2016-6-7 22:05
你好老师。
不需要自动的哦。要选取行区域后，运行代码，实现效果。

1. Sub xx()
   
2.     Dim rng As Range, i&, dc As Object, c As Integer, x As Integer
   
3.     Set rng = Selection
   
4.     If Application.Count(rng) < 10 Then Exit Sub  '至少选择10个，需要与参数匹配
   
5.     If rng.Rows.Count > 1 Then Exit Sub
   
6.     c = rng.Columns.Count
   
7.     Set dc = CreateObject("scripting.dictionary")
   
8.     On Error Resume Next
   
9.     With dc
   
10.         Do
    
11.             Randomize
    
12.             x = Int(Rnd * c + 1)
    
13.             If Not dc.Exists(x) Then
    
14.                 .Add x, ""
    
15.                 rng(1, x).Interior.Color = 192
    
16.             End If
    
17.         Loop Until .Count = 10  '在此修改参数
    
18.     End With
    
19. End Sub

复制代码

excelpxfans001

老司机带带我 发表于 2016-6-7 22:14

非常感谢老师的耐心解答，已实现。

能否加一个要求：运行代码，实现效果后，可否光标直接定位到第一个填充单元格。

fjmxwrs

在循环之前加上一句即可

1. rng.Interior.ColorIndex = 0

复制代码

老司机带带我

excelpxfans001 发表于 2016-6-7 22:30
非常感谢老师的耐心解答，已实现。

能否加一个要求：运行代码，实现效果后，可否光标直接定位到第一个 ...

你指的第一个是第一个填充了红色的还是说从左到右第一个红色的单元格？

excelpxfans001

老司机带带我 发表于 2016-6-7 22:40
你指的第一个是第一个填充了红色的还是说从左到右第一个红色的单元格？

从左至右的第一个填充红色的单元格。

老司机带带我

excelpxfans001 发表于 2016-6-7 22:42
从左至右的第一个填充红色的单元格。

1. Sub xx()
   
2.     Dim rng As Range, i&, dc As Object, c As Integer, x As Integer, y As Integer
   
3.     On Error Resume Next
   
4.     Set rng = Selection
   
5.     If Application.Count(rng) < 10 Then Exit Sub  '至少选择10个，需要与参数匹配
   
6.     If rng.Rows.Count > 1 Then Exit Sub
   
7.     c = rng.Columns.Count
   
8.     Set dc = CreateObject("scripting.dictionary")
   
9.     rng.Interior.ColorIndex = 0
   
10.     y = 2000
    
11.     With dc
    
12.         Do
    
13.             Randomize
    
14.             x = Int(Rnd * c + 1)
    
15.             If Not dc.Exists(x) Then
    
16.                 .Add x, ""
    
17.                 rng(1, x).Interior.Color = 192
    
18.                 If x < y Then y = x
    
19.             End If
    
20.         Loop Until .Count = 10  '在此修改参数
    
21.     End With
    
22.     rng(1, y).Select
    
23. End Sub

复制代码