[已解决]求高手帮忙修改代码

h486

我写的这段代码想用vba把需要数据粘贴到发放表内（按条件选择后顺序排列，并实现左右的粘贴），可是写的这段代码没办法从a3开始排序，请高手帮忙。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-3-30 09:22

1. Sub test()
   
2. On Error Resume Next
   
3. Dim rng As Range, arr, i&, s&, x&, d
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheet2.Range("a1").CurrentRegion
   
6. Sheet1.Activate
   
7. Set rng = Union([a3:a32], [e3:e32])
   
8. rng.ClearContents
   
9. For Each cel In rng
   
10.     x = x + 1
    
11.     d(x) = cel.Address
    
12. Next
    
13. For i = 2 To UBound(arr)
    
14.     If arr(i, 1) = "b部门" Or arr(i, 1) = "c部门" Then
    
15.         s = s + 1
    
16.         Range(d(s)).Resize(1, 3) = Application.Index(arr, i, 0)
    
17.     End If
    
18. Next
    
19. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub test()
   
2.    Dim x%, j%
   
3.     j = 3
   
4.     x = 2
   
5.     Do While j <= 33
   
6.         If Sheet2.Range("a" & x) = "b部门" Or Sheet2.Range("a" & x) = "c部门" Then
   
7.             Cells(j, "e").Resize(1, 3) = Sheet2.Range("a" & x, "c" & x).Value
   
8.             j = j + 1
   
9.         End If
   
10.         x = x + 1
    
11.     Loop
    
12. End Sub
    

复制代码

hwc2ycy

方法不对。
原有的代码第一个符合条件的数据出现时，CEL已经是E6单元格了。

h486

hwc2ycy 发表于 2014-3-29 23:05
方法不对。
原有的代码第一个符合条件的数据出现时，CEL已经是E6单元格了。

对不起版主，我要的效果是把原始数据粘贴到发放表内，从而实现左右粘贴。

h486

真的太难了。

h486

可有高手出手相助。:'(:'(:'(

蓝粆

耐心点~~我都没被打倒~~

h486

蓝粆 发表于 2014-3-29 23:35
耐心点~~我都没被打倒~~

一个问题潜伏多日无人能解，怎不让人抓狂？
不过之前那段代码我看懂了，可惜就差条件设置了，真叫人欲哭无泪！！！！！！！！！！！！！！！！！！！！！！

h486

hwc2ycy 发表于 2014-3-29 23:05
方法不对。
原有的代码第一个符合条件的数据出现时，CEL已经是E6单元格了。

版主老大，可有良法。

蓝粆

h486 发表于 2014-3-29 23:39
一个问题潜伏多日无人能解，怎不让人抓狂？
不过之前那段代码我看懂了，可惜就差条件设置了，真叫人欲哭 ...

还不怎么能看懂、、、