Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3305|回复: 8

[已解决]有什么方法能将一个表格拆分成多个表格

[复制链接]
发表于 2015-8-25 20:04 | 显示全部楼层 |阅读模式
我现在有一个总表,怎么样才能将其按照指定列拆分成多个表格??我在网上查到了下面公式,但是他是从第二行开始拆分的,各位大神,能不能改写一下,改成从的三行还是拆分!!(第一行是合并单元格,第二行是名称,第三行开始是需要拆分的内容)

Sub chaifen()
Dim a, b(), d, icol, c, rng, l
On Error Resume Next
a = Columns("c")
Set rng = Sheet1.UsedRange
1000:
icol = Application.InputBox("请输入需要拆分的列号:", , "请输入A, B, C……", , , , 2)
If icol = "请输入A, B, C……" Then
MsgBox "没有输入拆分列号!": GoTo 1000
ElseIf icol = False Then
Exit Sub

ElseIf Cells(1, icol).Column > rng.End(xlToRight).Column Then
MsgBox "输入的列号无效或已超过有效范围!": GoTo 1000
End If
Application.ScreenUpdating = False

a = Intersect(rng, Columns(icol))
c = rng
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(a)
If Not d.exists(a(i, 1)) Then
d(a(i, 1)) = i
Else
d(a(i, 1)) = d(a(i, 1)) & "," & i
End If
Next i
k = d.keys
p = ThisWorkbook.Path & "\"
For i = 0 To d.Count - 1
x = Split(d(k(i)), ",")
ReDim b(1 To UBound(x) + 2, 1 To UBound(c, 2))
For j = 1 To UBound(c, 2)
b(1, j) = c(1, j)
Next j
m = 1
For l = 0 To UBound(x)
m = m + 1
For j = 1 To UBound(c, 2)
b(m, j) = c(x(l), j)
Next j
Next l
For j = 1 To UBound(c, 2)
If VBA.IsNumeric(b(2, j)) And Len(b(2, j)) >= 12 Then ss = j
Next j
rng.Rows(2).Copy
With Workbooks.Add
.Sheets(1).[a1].Resize(m, UBound(c, 2)).PasteSpecial Paste:=xlPasteFormats
.Sheets(1).Columns(ss).NumberFormatLocal = "@"
.Sheets(1).[a1].Resize(m, UBound(c, 2)) = b
.SaveAs Filename:=p & k(i) & ".xls"
.Close
End With
Next i
MsgBox "拆分完毕!"
Application.ScreenUpdating = True
End Sub


excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2015-8-25 20:44 | 显示全部楼层
好多蚯蚓,不会VBA,但是我会用透视表拆表格,呵呵~

坐等其他高手解答学习...
回复

使用道具 举报

 楼主| 发表于 2015-8-25 22:40 | 显示全部楼层
这个是需要拆分的试例,源文件太大上传不了,我需要按照“所属台区名称”这一列进行拆分,希望那个高手能帮帮忙,谢谢!

拆分.zip

11.02 KB, 下载次数: 10

回复

使用道具 举报

发表于 2015-8-26 08:29 | 显示全部楼层
  1. Sub 拆分到不同工作表中()
  2. Application.ScreenUpdating = False
  3. On Error Resume Next
  4. With Worksheets("Sheet1")
  5.     For i = 3 To .[A65536].End(xlUp).Row
  6.     nam = .Cells(i, "j")
  7.         If Worksheets(nam) Is Nothing Then
  8.             Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = nam
  9.             .Rows("1:2").Copy Worksheets(nam).[a1]
  10.         End If
  11.         .Rows(i).Copy Worksheets(nam).[A65536].End(xlUp).Offset(1, 0)
  12.     Next
  13. End With
  14. Application.ScreenUpdating = True
  15. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-8-26 08:48 | 显示全部楼层
七彩屋 发表于 2015-8-26 08:29

我需要的是拆分成到多个单独的表格中,不是拆分成多个工作表
回复

使用道具 举报

 楼主| 发表于 2015-8-27 08:47 | 显示全部楼层
等待大神帮忙中。。。。。。。。
回复

使用道具 举报

发表于 2015-8-27 09:42 | 显示全部楼层    本楼为最佳答案   
gfs2f23.gif


可以用这个来做。
http://www.excelpx.com/thread-297695-1-1.html
回复

使用道具 举报

 楼主| 发表于 2015-9-6 23:47 | 显示全部楼层
爱疯 发表于 2015-8-27 09:42
可以用这个来做。
http://www.excelpx.com/thread-297695-1-1.html

为什么我拆分的时候会出现这个,要怎么解决? QQ图片20150906234024.png
回复

使用道具 举报

发表于 2015-9-7 08:59 | 显示全部楼层
sdf2f2.gif


http://www.excelpx.com/thread-297695-22-1.html
我用220楼,拆分了你3楼附件,见动画。

不知你是怎样操作的?
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 13:02 , Processed in 0.374423 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表