由总表拆分成各个工作表

ralfqiu · 发表于 2014-9-12 14:36

本帖最后由 ralfqiu 于 2014-9-12 16:03 编辑

本人为VBA初学者，每次想做一些VBA时都会先在坛子上搜索一下。果不其然，这次在坛子上搜到了相似需求的帖子。
附件1为我需要实现的文件，我想实现的是根据第一张数据总表的经销商号，拆分成各个经销商号的Sheet，表头需要保留。在使用了例子的语句后，前期的筛选、建立新的Sheet、复制表头都已经成功实现，可就是在复制相关内容时进入了死循环。求各位大神帮助，谢谢

附上附件

附件1.zip (362.7 KB, 下载次数: 10)

例子.rar (25.67 KB, 下载次数: 9)

ralfqiu · 发表于 2014-9-12 15:33

有老师帮帮忙吗？

魂断蓝桥 · 发表于 2014-9-12 15:44

Sub t()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim arr, d, k, i As Integer, ts As String
Dim sh As Worksheet
arr = Sheet1.[a1].CurrentRegion
Set d = CreateObject("Scripting.Dictionary")
ts = MsgBox("只保留总表", vbYesNo)
If ts = vbNo Then Exit Sub
For Each sh In Sheets
If sh.Name <> "总表" Then
      sh.Delete
End If
Next
For i = 2 To UBound(arr) - 1
d(arr(i, 3)) = ""
Next
k = d.keys
For i = 0 To d.Count - 1
With Sheet1
      .Range("a1:l1").AutoFilter Field:=3, Criteria1:=k(i)
      Sheets.Add(after:=Sheets(Sheets.Count)).Name = k(i)
      .Range("a1:l" & .[a65536].End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy ActiveSheet.[a1]
      '.[a1:g2].Copy ActiveSheet.[a1]
End With
Next
Sheet1.Range("c1").AutoFilter
Sheet1.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "拆分OK，共拆分" & d.Count & "张表" & Chr(10) & Chr(10) & Join(k, ";")
Set d = Nothing

End Sub

ralfqiu · 发表于 2014-9-12 15:57

魂断蓝桥发表于 2014-9-12 15:44
Sub t()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

老师您好，我想做的文件是jhanxasd这个附件。。。

ralfqiu · 发表于 2014-9-12 16:49

等待老师出现~~

a68508122 · 发表于 2014-9-12 17:46

TEST01.rar (303.51 KB, 下载次数: 16)
下班了临时做了一个边框等还没做

a68508122 · 发表于 2014-9-13 09:51

test02.rar (313.35 KB, 下载次数: 65)
完美一下，希望您满意
设置参数n，想要哪列就哪列

ralfqiu · 发表于 2014-9-13 14:35

a68508122 发表于 2014-9-13 09:51
完美一下，希望您满意
设置参数n，想要哪列就哪列

多谢老师用自己的写法实现了我的目的。。。

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

[求助] 由总表拆分成各个工作表