要求根据汇总表的村名筛选出的新表，自动创建到新的sheet

hanksky

要求根据村名 列，然后筛选出的新表，自动创建到新的sheet。也就是说每个村分别一个sheet ，让他们更改添加，然后我在汇总。

liulang0808

http://club.excelhome.net/thread-1385473-1-1.html
第五个，是否可以参考下

lsc900707

注册eh八年了，就一个按列拆分的问题呀。

lsc900707

1. Private Sub CommandButton1_Click()
   
2.     tms = Timer
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = ActiveSheet.UsedRange
   
6.     m = UBound(arr): n = UBound(arr, 2)
   
7.     Set Rng = [a1].Resize(3, n)
   
8.     For i = 4 To m
   
9.         If Not d.exists(arr(i, 13)) Then
   
10.             Set d(arr(i, 13)) = Range("a" & i).Resize(1, n)
    
11.         Else
    
12.             Set d(arr(i, 13)) = Union(d(arr(i, 13)), Range("a" & i).Resize(1, n))
    
13.         End If
    
14.     Next
    
15.     x = d.keys
    
16.     For k = 0 To UBound(x)
    
17.         Set sht = ActiveWorkbook.Sheets.Add(, after:=ActiveSheet)
    
18.         sht.Name = x(k)
    
19.         d.items()(k).Copy sht.[a4]
    
20.         Rng.Copy sht.[a1]
    
21.     Next
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox Format(Timer - tms, "拆分完成，共耗时：0.00秒")
    
24. End Sub
    

复制代码

lsc900707

代码在审核，先测试附件吧：

hanksky

lsc900707 发表于 2018-9-7 19:48
注册eh八年了，就一个按列拆分的问题呀。

呵呵，现在用的少了，就很少学。。谢谢老师了。

hanksky

lsc900707 发表于 2018-9-7 20:06
代码在审核，先测试附件吧：

谢谢，就是这个结果。

hanksky

lsc900707 发表于 2018-9-7 20:03

这个代码的 那个条件 是判定 M列为条件的，如果我要改别的条件比如说 A列 为条件 ，改哪一行的代码

hanksky

找到了，找到。 改et d(arr(i, 13))  改代码里面的13，这个意思就是 13列么。

lsc900707

hanksky 发表于 2018-9-8 14:26
找到了，找到。 改et d(arr(i, 13))  改代码里面的13，这个意思就是 13列么。

是的。可以修改成任意列的。