[已解决]按列拆分工作表

shaokui123 · 发表于 2014-4-20 13:46

Book1.rar (6.97 KB, 下载次数: 16)

dsmch · 发表于 2014-4-20 15:00

Sub Macro1()
On Error Resume Next
Dim arr, d, i&
Set d = CreateObject("scripting.dictionary")
arr = Range("a3").CurrentRegion
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
If Sheets(i).Name <> "数据" Then Sheets(i).Delete
Next
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 2)) Then
d(arr(i, 2)) = ""
Sheet1.[b3].AutoFilter Field:=2, Criteria1:=arr(i, 2)
With Sheets.Add(after:=Sheets(Sheets.Count))
.Name = arr(i, 2)
Sheet1.[a:d].Copy [a1]
End With
Sheet1.ShowAllData
End If
Next
Sheet1.Activate
[a3].AutoFilter
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

dsmch · 发表于 2014-4-20 15:01

增加了一行标题

跑跑2014 · 发表于 2014-4-20 15:10

本帖最后由跑跑2014 于 2014-4-20 15:20 编辑

用了筛选功能

如要有标题，直接把代码改为
Sub Macro1()
Sheet2.Rows("1:65536").Delete
Sheet3.Rows("1:65536").Delete
d = Sheet1.Range("a65536").End(xlUp).Row
Sheet1.Range("B:B").AutoFilter Field:=1, Criteria1:="内"
Range("A1:D" & d).Copy Sheet2.Range("a1")
Sheet1.Range("B:B").AutoFilter Field:=1, Criteria1:="外"
Range("A1:D" & d).Copy Sheet3.Range("a1")
Sheet1.Columns("B:B").AutoFilter
End Sub

shaokui123 · 发表于 2014-4-20 18:30

感谢大家非常好用，谢谢了

shaokui123 · 发表于 2014-4-30 19:48

跑跑2014 发表于 2014-4-20 15:10
用了筛选功能

如要有标题，直接把代码改为

你好朋友
现在使用的代码就是您帮助写的
但是发现有点问题
当b列全是内的情况下
点击按钮外表格也是内的内容
也就是没有区分了
请您帮忙再修改一下

跑跑2014 · 发表于 2014-4-30 20:16

本帖最后由跑跑2014 于 2014-4-30 21:00 编辑

shaokui123 发表于 2014-4-30 19:48
你好朋友
现在使用的代码就是您帮助写的
但是发现有点问题

Sub Macro1()
Sheet2.Rows("1:65536").Delete
Sheet3.Rows("1:65536").Delete
d = Sheet1.Range("a65536").End(xlUp).Row
Sheet1.Range("B:B").AutoFilter Field:=1, Criteria1:="内"
Range("A1:D" & d).Copy Sheet2.Range("a1")
Sheet1.Range("B:B").AutoFilter Field:=1, Criteria1:="外"
Range("A1:D" & d).Copy Sheet3.Range("a1")
Sheet1.Columns("B:B").AutoFilter
End Sub
用这段代码就不会发生那种情况　了。

shaokui123 · 发表于 2014-4-30 21:15

跑跑2014 发表于 2014-4-30 20:16
Sub Macro1()
Sheet2.Rows("1:65536").Delete
Sheet3.Rows("1:65536").Delete

朋友，确实是存在问题
当数据表中b列全是单一数值的时候，比如全是内
那么外的表格中就把所有的数值全部复制了过去
我刚刚把附件下载了又重新测试了一遍，还是有问题

跑跑2014 · 发表于 2014-4-30 21:20

本帖最后由跑跑2014 于 2014-4-30 21:25 编辑

shaokui123 发表于 2014-4-30 21:15
朋友，确实是存在问题
当数据表中b列全是单一数值的时候，比如全是内
那么外的表格中就把所有的数值全部 ...

改为 Sheet2.Rows("1:65536").Delete
Sheet3.Rows("1:65536").Delete
Sheet1.Rows("1:1").Insert
d = Sheet1.Range("a65536").End(xlUp).Row
Sheet1.Range("B:B").AutoFilter Field:=1, Criteria1:="内"
Sheet1.Range("A1:D" & d).Copy Sheet2.Range("a1")
Sheet1.Range("B:B").AutoFilter Field:=1, Criteria1:="外"
Sheet1.Range("A1:D" & d).Copy Sheet3.Range("a1")
Sheet1.Rows("1:1").Delete
Sheet2.Rows("1:1").Delete
Sheet3.Rows("1:1").Delete
其时要是有标头用第二段代码

shaokui123 · 发表于 2014-4-30 21:34

跑跑2014 发表于 2014-4-30 21:20
改为 Sheet2.Rows("1:65536").Delete
Sheet3.Rows("1:65536").Delete
Sheet1.Rows("1:1"). ...

你好朋友
这次正常了
测试中

		自动登录	找回密码
密码			注册

[已解决]按列拆分工作表

相关帖子

点评