[已解决]多条件复制粘贴

mate33

多条件复制粘贴的VBA

最佳答案

月排行榜 / 总排行榜

grf1973

2017-4-21 13:18

1. Sub tt()
   
2.     Dim cel As Range, rng As Range
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set rng = Selection
   
5.     ReDim brr(1 To rng.Cells.Count, 1 To 3)
   
6.     For Each cel In rng
   
7.         x = cel.Value
   
8.         n = n + 1
   
9.         brr(n, 1) = x: brr(n, 2) = x: brr(n, 3) = x
   
10.         d(x) = ""
    
11.     Next
    
12.     If d.Count <= 6 Then MsgBox "选择区域中不同数字的个数小于等于6个，不粘贴。": Exit Sub
    
13.     For Each cel In ActiveSheet.UsedRange
    
14.         If cel.Interior.ColorIndex = 6 Then c = cel.Column: Exit For
    
15.     Next
    
16.     If Len(c) = 0 Then MsgBox "未找到黄色区域": Exit Sub
    
17.    
    
18.     r = Cells(65536, c).End(3).Row + 1
    
19.     If r < 30 Then r = 30
    
20.     Cells(r, c).Resize(n, 3) = brr
    
21. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     Dim cel As Range, rng As Range
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set rng = Selection
   
5.     ReDim brr(1 To rng.Cells.Count, 1 To 3)
   
6.     For Each cel In rng
   
7.         x = cel.Value
   
8.         n = n + 1
   
9.         brr(n, 1) = x: brr(n, 2) = x: brr(n, 3) = x
   
10.         d(x) = ""
    
11.     Next
    
12.     If d.Count <= 6 Then MsgBox "选择区域中不同数字的个数小于等于6个，不粘贴。": Exit Sub
    
13.     For Each cel In ActiveSheet.UsedRange
    
14.         If cel.Interior.ColorIndex = 6 Then c = cel.Column: Exit For
    
15.     Next
    
16.     If Len(c) = 0 Then MsgBox "未找到黄色区域": Exit Sub
    
17.    
    
18.     r = Cells(65536, c).End(3).Row + 1
    
19.     If r < 30 Then r = 30
    
20.     Cells(r, c).Resize(n, 3) = brr
    
21. End Sub
    

复制代码