excl数据分类代码求教！

yanlj518

把sheet1的数据按班级复到各自工作表中，代码死循环了，求教高手！

roych

楼主的思路估计是想一行行复制粘贴。但这里有一个问题需要解决：粘贴完每一行，都需要记录被粘贴的位置，否则下次粘贴就会出现空行。

这样说可能有些难以理解。打个比方：
第一次，复制数据源的第2行，粘贴到工作表“1”的第2行，这时候记下这个位置A。
第二次，复制第3行，粘贴到工作表“2”的第2行，再记下这个位置B。
第三次，复制第4行，粘贴到工作表“1”的位置A的下一行，并更新位置A。
…………
这只是2个工作表，就要记下2个位置，不仅需要避免混淆，还需要更新。
因此如果一行行复制，需要定义一个字典或者集合，以工作表名称为键名（key），以位置作为键值（value），才能完成这个任务。
个人觉得比较复杂，因此采用一种更加方便的做法，就是使用自动筛选，根据筛选值的个数复制粘贴，这样的话，相对来说，效率也会高一些，逐行复制粘贴20次，但自动筛选只有2次。而且不容易混淆。毕竟一个班只会复制粘贴一次。
代码如下：

1. Sub feilei()
   
2. 
   
3. 
   
4.     Dim lngRows As Long
   
5.     Dim i As Long
   
6.     Dim lngClass As Long
   
7.     Dim dict As New Dictionary
   
8.     Dim key As Variant
   
9.     '获取行数
   
10.     lngRows = Sheet1.UsedRange.Rows.Count
    
11.    
    
12.    
    
13.     '筛选不重复班级,丢进字典里，用于后续筛选
    
14.     For i = 2 To lngRows
    
15.         lngClass = Sheet1.Range("C" & i)
    
16.         If Not dict.Exists(lngClass) Then
    
17.             dict(lngClass) = ""
    
18.         End If
    
19.     Next
    
20.    
    
21.    
    
22.    
    
23.     For Each key In dict.Keys
    
24.     '激活工作表
    
25.         Sheet1.Activate
    
26.     '筛选数据
    
27.         Sheet1.Range("A1:G" & lngRows).AutoFilter 3, key
    
28.     '复制筛选结果
    
29.         Sheet1.Range("A2:G" & lngRows).Select
    
30.         Selection.Copy
    
31.         For i = 1 To Sheets.Count
    
32.         '如果工作表名称和筛选条件相同（由于name是文本类型，因此需要使用cstr转为文本，否则将无法粘贴或者报错）
    
33.             If Sheets(i).Name = CStr(key) Then
    
34.                 Sheets(i).Activate
    
35.                 '激活A2单元格
    
36.                 Sheets(i).Range("A2").Activate
    
37.                 '粘贴数据后跳出循环，可以减少循环次数
    
38.                 ActiveSheet.Paste
    
39.                 Exit For
    
40.             End If
    
41.         Next
    
42.     Next
    
43.     '取消自动筛选
    
44.     Sheet1.Range("A1:G" & lngRows).AutoFilter
    
45.    
    
46.    
    
47. End Sub
    
48. 
    

复制代码