如何将总表拆分成多个分表

杳杳大魔王 · 发表于 2019-2-11 18:38

怎么将数据源拆分成以部门为单位的多个分表

杳杳大魔王 · 发表于 2019-2-11 18:40

求大神指导

2489586288 · 发表于 2019-2-11 20:43

按列拆分，老生常谈

杳杳大魔王 · 发表于 2019-2-12 10:18

2489586288 发表于 2019-2-11 20:43
按列拆分，老生常谈

求大神指导，谢谢

左面的鱼 · 发表于 2019-2-13 17:35

本帖最后由左面的鱼于 2019-2-13 17:36 编辑

按列拆分是不用VBA就能实现吗？想知道。
这个问题网上搜搜就能找到代码。
下面代码就是按A列拆分，从网上找的。

Sub Sepsheets()
' Sepsheets Macro
' 将工作薄的内容按A列分类从第二行开始放入不同工作薄中。
Dim i As Integer
Dim j As Integer
' i & j 用于行循环
Dim k As Integer
Dim h As Integer
' k & h用于excel表单循环
Dim m As Integer
'm用于根据表头内容判断有多少列需要分页
Dim n As Integer
'临时变量，用于判断是否需要新建表单
Dim p As String
'p 代表当前工作表单表单名
Dim q As String
'q用于表示以A列中分类的内容为名建立的表单
Range("a1").Select
p = ActiveSheet.Name
j = ActiveSheet.[a65536].End(3).Row
m = Sheets(p).Cells(1, 256).End(xlToLeft).Column
h = Sheets.Count
n = 0
For i = 2 To j
Sheets(p).Select
If Range("A" & i).Value <> "" Then
For k = 1 To h
If Sheets(k).Name <> Range("A" & i).Value Then
n = n + 1
End If
Next k
If n = h Then
Sheets.Add after:=Sheets(h)
h = h + 1
Sheets(h).Name = Sheets(p).Range("A" & i).Value
Sheets(p).Range("A1:" & Chr(m + 64) & "1").Copy Sheets(h).Range("a1")
End If
n = 0
q = Sheets(p).Range("A" & i).Value
Sheets(p).Range("A" & i & ":" & Chr(m + 64) & i).Copy Sheets(q).[a65536].End(3).Offset(1, 0)
End If
Next i
End Sub

复制代码

xrmay · 发表于 2019-12-7 00:15

收藏一下

ykcbf1100 · 发表于 2024-5-3 16:19

本帖最后由 ykcbf1100 于 2024-5-3 16:38 编辑

虽然是多年前的求助帖子，但既然没有解决，那我就写一个呗。
原格式总表拆分为多表
纯练手。。。

ykcbf1100 · 发表于 2024-5-3 16:20

练手而已。。。

总表拆分为多表。

Sub ykcbf2() '//2024.5.3
Dim arr, brr, d
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
Set ws = ThisWorkbook
Set sh = ws.Sheets("数据源")
bt = 1: col = 2
For Each sht In Sheets
If sht.Name <> sh.Name Then sht.Delete
Next
arr = sh.UsedRange
For i = 3 To UBound(arr)
s = arr(i, col)
If Not d.Exists(s) Then
Set d(s) = CreateObject("scripting.dictionary")
End If
d(s)(i) = Application.Index(arr, i)
Next i
For Each k In d.keys
sh.Copy after:=Sheets(Sheets.Count)
Set sht = Sheets(Sheets.Count)
m = d(k).Count
With sht
.Name = k
.UsedRange.Offset(m + bt).Clear
.DrawingObjects.Delete
.Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
End With
Next k
sh.Activate
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "共用时：" & Format(Timer - tm) & "秒！"
End Sub

复制代码

学习_2018 · 发表于 2024-5-3 18:29

提示: 作者被禁止或删除内容自动屏蔽

gwjkkkkk · 发表于 2024-5-3 19:05

Option Explicit
Sub TEST0()
Dim ar, br, cr, i&, j&, dic As Object, vKey, wks As Worksheet

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")

ar = Sheets("数据源").[A1].CurrentRegion.Value
For i = 2 To UBound(ar)
      dic(ar(i, 2)) = dic(ar(i, 2)) & " " & i
Next i

With Workbooks.Add
      For Each vKey In dic.keys
         cr = Split(dic(vKey))
         ReDim br(1 To UBound(cr) + 1, 1 To UBound(ar, 2))
         For j = 1 To UBound(ar, 2): br(1, j) = ar(1, j): Next
         For i = 1 To UBound(cr)
            For j = 1 To UBound(ar, 2)
                  br(i + 1, j) = ar(cr(i), j)
            Next j
         Next i
         With .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
            .Name = vKey
            .[A1].Resize(UBound(br), UBound(br, 2)) = br
         End With
      Next
      For Each wks In .Worksheets
         If wks.Name Like "*Sheet*" Then wks.Delete
      Next
End With

Set dic = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Beep
End Sub

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

如何将总表拆分成多个分表

评分

评分

学习_2018 学习_2018 当前离线性别保密 UID 4075763 阅读权限 0 注册时间 2018-8-12 在线时间小时最后登录 1970-1-1 积分 27 财富分享技术精华头像被屏蔽 TA的精华主题 TA的得分主题	发表于 2024-5-3 18:29 \| 显示全部楼层 [广告] ★ExcelHome默写助手 - 不用妈妈陪的默写神器 · Word/WPS插件 · 自定义默写单 · 自定义描红字帖★ 提示: 作者被禁止或删除内容自动屏蔽

	回复举报