用vba将excel按要求将一个表批量拆分成多个表

微风徐徐2016 · 发表于 2020-3-8 19:45

求大神帮忙，如何将下图的表批量拆分成按date那一列每个日期一个表的形式啊
附件只能传两个上来，因为太大了，我分成了四个

2001-2004.rar (1.54 MB, 下载次数: 4)

2005-2008.rar (1.55 MB, 下载次数: 8)

3190496160 · 发表于 2020-3-9 10:13

Excel 灵活拆分工具-ExcelVBA程序开发-ExcelHome技术论坛 - http://club.excelhome.net/thread-1520853-1-1.html
到这个帖子的9楼去下载吧，下载后把你的数据拷贝到工作表中，就能用，完全可以满足你的需求的

shenjianrong163 · 发表于 2020-3-9 12:01

Sub test()
Dim i, j, d, k, arr, brr()
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With Worksheets("2005-2008")
arr = .UsedRange
End With
For i = 2 To UBound(arr)
d(arr(i, 2)) = ""
Next
For Each aa In d.Keys
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
k = 1
Workbooks.Add
Set wb = ActiveWorkbook
With wb
If .Sheets(1).Name <> "Sheet1" Then .Sheets(1).Name = "Sheet1"
.SaveAs Filename:=ThisWorkbook.Path & "" & aa & ".xlsx", FileFormat:=xlWorkbookDefault
For j = 1 To UBound(arr, 2)
brr(k, j) = arr(k, j)
Next
For i = 2 To UBound(arr)
If aa = arr(i, 2) Then
k = k + 1
For j = 1 To UBound(brr, 2)
brr(k, j) = arr(i, j)
Next
End If
Next
[A1].Resize(k, UBound(brr, 2)) = brr
.Close True
End With
Erase brr
Next
Application.ScreenUpdating = True
MsgBox "2e·Öíê3é"
End Sub

复制代码

shenjianrong163 · 发表于 2020-3-9 12:09

请参考附件（由于文件过大，删除了部分数据）：

2005-2008.rar (1.37 MB, 下载次数: 3)

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

最新热点 /1