[已解决]求VB代码！！！！

star9s

求VB代码！！！！感谢。要求：SHEET1对应Sheet2，SHEET1 A列对应Sheet2 A列填充颜色，B列对应B列填充颜色，C列对应C列填充颜色以此类推，数据较多，需要填充迅速，预计Sheet2每列有60000格,预计共50列，Sheet1提供数值范围（1-100）

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-5-6 10:21

单元格逐个判断改色操作效率不可能很高的，我用了变通的方法，代码如下：

1. Sub aaa()
   
2. Dim arr, i&, j&, d As Object
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheets(1).[a1].CurrentRegion
   
6. For j = 1 To UBound(arr, 2)
   
7.   Set d(j) = CreateObject("scripting.dictionary")
   
8.   For i = 1 To UBound(arr)
   
9.     If arr(i, j) <> "" Then d(j)(arr(i, j)) = ""
   
10.   Next i
    
11. Next j
    
12. arr = Sheets(2).[a1].CurrentRegion
    
13. For j = 1 To UBound(arr, 2)
    
14.   For i = 1 To UBound(arr)
    
15.     If d(j).exists(arr(i, j)) Then arr(i, j) = "=" & arr(i, j)
    
16.   Next i
    
17. Next j
    
18. Sheets(2).[a1].CurrentRegion = arr
    
19. Sheets(2).Cells.SpecialCells(xlCellTypeFormulas).Interior.Color = RGB(226, 239, 218)
    
20. Sheets(2).[a1].CurrentRegion = Sheets(2).[a1].CurrentRegion.Value
    
21. Application.ScreenUpdating = True
    
22. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

单元格逐个判断改色操作效率不可能很高的，我用了变通的方法，代码如下：

1. Sub aaa()
   
2. Dim arr, i&, j&, d As Object
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheets(1).[a1].CurrentRegion
   
6. For j = 1 To UBound(arr, 2)
   
7.   Set d(j) = CreateObject("scripting.dictionary")
   
8.   For i = 1 To UBound(arr)
   
9.     If arr(i, j) <> "" Then d(j)(arr(i, j)) = ""
   
10.   Next i
    
11. Next j
    
12. arr = Sheets(2).[a1].CurrentRegion
    
13. For j = 1 To UBound(arr, 2)
    
14.   For i = 1 To UBound(arr)
    
15.     If d(j).exists(arr(i, j)) Then arr(i, j) = "=" & arr(i, j)
    
16.   Next i
    
17. Next j
    
18. Sheets(2).[a1].CurrentRegion = arr
    
19. Sheets(2).Cells.SpecialCells(xlCellTypeFormulas).Interior.Color = RGB(226, 239, 218)
    
20. Sheets(2).[a1].CurrentRegion = Sheets(2).[a1].CurrentRegion.Value
    
21. Application.ScreenUpdating = True
    
22. End Sub

复制代码

star9s

确实比较慢，不够快，另一个VB给出的方案很快，但是填充的颜色却查询不出来，并且填充后的颜色覆盖不了其他颜色，可不可以修改一下，按照上诉条件填充颜色呢？并且填充的颜色可以查询与删除，代码如下：
Sub ss填充颜色()

t = Timer


dd = 1
sh = Sheet1.UsedRange.Rows.Count

a = 2


For x = 1 To 60

For y = 2 To sh



shuj = Cells(y, a - 1)

If shuj = "" Then

y = sh
End If


Range(Cells(1, a), Cells(1, a)).EntireColumn.Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:=shuj

    With Selection.FormatConditions(dd).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 192
        .TintAndShade = 0
    End With

      

   
dd = dd + 1

    Next
        a = a + 3
        
        dd = 1
        
    Next
   
      MsgBox "本次耗时：" & Timer - t
   
   
End Sub

池盛龙

star9s 发表于 2017-5-6 12:28
确实比较慢，不够快，另一个VB给出的方案很快，但是填充的颜色却查询不出来，并且填充后的颜色覆盖不了其他 ...

你要怎么查询？

大灰狼1976

star9s 发表于 2017-5-6 12:28
确实比较慢，不够快，另一个VB给出的方案很快，但是填充的颜色却查询不出来，并且填充后的颜色覆盖不了其他 ...

这个是设置的条件格式，本质不一样。

star9s

大灰狼1976 发表于 2017-5-6 12:44
这个是设置的条件格式，本质不一样。

试了一下，确实太慢了，池盛龙方法快，但是不能查询颜色，统计颜色，我对VB不懂，所以不知道原因出在哪

star9s

池盛龙 发表于 2017-5-6 12:41
你要怎么查询？

按照上诉条件填充颜色，但你的代码填充的颜色不能查询，统计

池盛龙

查询在哪里

大灰狼1976

star9s 发表于 2017-5-6 12:51
试了一下，确实太慢了，池盛龙方法快，但是不能查询颜色，统计颜色，我对VB不懂，所以不知道 ...

条件格式确实比修改单元格颜色要快得多，但不能直接获取单元格显示的颜色，而是需要根据设定的条件逐个单元格判断。
我的方法其实比循环遍历修改单元格颜色已经快很多了，懂的人一看就明白，最后一句用replace方法修改的话还会快一点，因为数据量大时回写很慢。