本帖最后由 likeyouli 于 2022-11-22 15:05 编辑
单位领导安排的，要把一个excel表中的几十万数据（有姓名、身份证号、联系电话、参保单位等列），按照“参保单位”分类导出到单个的excel表格文件，细看了下，参保单位大约上千个，一个一个导出估计能把我累出血，研究了一天，终于成功，，高手别嘲笑....
1. 利用数据透视表，将这一个工作表，拆分为多个工作表：插入透视表，将参保单位拖到筛选器，其余列拖到行；选中设计菜单，分类汇总选中 不显示分类汇总，总计勾选 对行和列禁用，报表布局选中 以表格形式显示，同时选中 “重复所有项目标签”（这里务必注意，本人刚开始没注意，导致重复的姓名或重复的其他内容 老是显示空白，还以为透视数据出问题了呢，研究了半天才发现是这个原因），别忘了把-按钮去除，最后点选项，显示报表筛选页，就会自动生成一个一个按参保单位命名的工作表。通过shift键，分别按第一个与最后一个新生成的工作表（即选中），全选复制，然后接着粘贴为数值，继续调整某一个工作表，达到自己想要的样式，因为是全选中状态，其余也会跟着改变。
2. 导出工作表，需要利用代码了，以excel 2016为例，新建空白命名的工作表，点开发工具，插入activeX控件，双击后输入如下代码：
Private Sub CommandButton1_Click()
Dim sht As Worksheet
For Each sht In Sheets
If sht.Name <> "空白" Then
sht.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "E:\wuyou\" & sht.Name & ".xlsx"
ActiveWorkbook.Close savechanges:=False
End If
Next
MsgBox "恭喜你，已完成！！"
End Sub （空白是你新建的输入代码的工作表名称，请根据实际替换）
运行后，便会自动将每一个工作表存为单独的excel文件。<br>
Sub 拆分带人数()
Dim sht As Worksheet, n%
For Each sht In Sheets
n = sht.UsedRange.Rows.Count - 2
If sht.Name <> "空白" Then
sht.Copy
ActiveWorkbook.SaveAs Filename:="V:\迅雷下载\" & sht.Name & n & "人未激活" & ".xlsx"
ActiveWorkbook.Close savechanges:=False
End If
Next
MsgBox "恭喜你，已完成！！"
End Sub---变量n赋值必须在for each之后，且用&连接变量n时必须前边有空格。.
不用透视表了，全部vba代码完成：
Sub 拆分并分别保存()
Dim x As Byte, f As Range, wb As Workbook
Range("a2", Cells(Rows.Count, 1).End(xlUp)).Copy [o1]
Range("o:o").RemoveDuplicates Columns:=1, Header:=xlNo
x = Application.WorksheetFunction.CountA([o:o])
Do
y = y + 1
Range("a1").AutoFilter 1, Cells(y, "o")
Set f = Range("a1").CurrentRegion
Set wb = Workbooks.Add
f.Copy wb.Sheets(1).[a1]
wb.SaveAs "E:\wuyou\" & ThisWorkbook.Sheets(1).Cells(y, "o") & ".xlsx"
wb.Close
Loop Until y = x
ThisWorkbook.Sheets(1).AutoFilterMode = False
[o:o].Delete
MsgBox "恭喜你，已完成！！"
End Sub
.
再换种写法：Sub 拆分并分别保存()Dim x As Byte, f As Range, wb As Workbook
Range("g2", Cells(Rows.Count, 7).End(xlUp)).Copy [z1]
Range("z:z").RemoveDuplicates Columns:=1, Header:=xlNo
x = Application.WorksheetFunction.CountA([z:z])
Do
y = y + 1
Range("a1").AutoFilter 7, Cells(y, "z")
Set f = Range("a1").CurrentRegion
Set wb = Workbooks.Add
f.Copy wb.Sheets(1).[a1]
wb.SaveAs "E:\wuyou\" & ThisWorkbook.Sheets(1).Cells(y, "z") & ".xlsx"
wb.Close
Loop Until y = x
ThisWorkbook.Sheets(1).AutoFilterMode = False
[z:z].Delete
MsgBox "恭喜你，已完成！！"
End Sub
又换种写法，带上总人数和未激活人数：
Sub 拆分并分别保存()
Dim x As Byte, f As Range, wb As Workbook
Range("g2", Cells(Rows.Count, 7).End(xlUp)).Copy [z1]
Range("z:z").RemoveDuplicates Columns:=1, Header:=xlNo
x = Application.WorksheetFunction.CountA([z:z])
Do
y = y + 1
Range("a1").AutoFilter 7, Cells(y, "z")
Set f = Range("a1").CurrentRegion
Set wb = Workbooks.Add
f.Copy wb.Sheets(1).[a1]
n = Cells(Rows.Count, 3).End(xlUp).Row'这里的活动工作表是新增的工作簿wb中的sheets(1),n是统计的这个工作表里的
p = Application.WorksheetFunction.CountIf([d:d], "已激活")
If ThisWorkbook.Sheets(1).Cells(y, "z") <> "" Then
wb.SaveAs "E:\wuyou\" & ThisWorkbook.Sheets(1).Cells(y, "z") & "总人数" & n - 1 & "未激活" & n - p - 1 & ".xlsx"
Else
wb.SaveAs "E:\wuyou\" & "不是乡镇" & "总人数" & n - 1 & "未激活" & n - p - 1 & ".xlsx"
End If
wb.Close
Loop Until y = x + 1
ThisWorkbook.Sheets(1).AutoFilterMode = False
[z:z].Delete
MsgBox "恭喜你，已完成！！"
End Sub
vba论坛,暂时放这里记忆一下,https://club.excelhome.net/forum.php.
Sub 拆分工作簿要求新增的工作簿含5个工作表 () Dim x%, wb As Workbook, f AsRange, x1&, a1 As Range, a2 As Worksheet Range("j2",Cells(Rows.Count, "j").End(xlUp)).Copy [z1] Range("z:z").RemoveDuplicatesColumns:=1, Header:=xlNo x = Cells(Rows.Count,"z").End(xlUp).Row Set wb1 =Workbooks("2022.1.1-10.29.xls").Sheets("nihao") For n = 0 To 50 Set wb = Workbooks.Add Do s = s + 1 n = n + 1 wb1.Range("a1").AutoFilter 10, wb1.Cells(n, "z") Set f = wb1.Range("a1").CurrentRegion If wb.Worksheets(1).Range("a1").CurrentRegion.Rows.Count <2 Then f.Copy wb.Sheets(1).Range("a1") wb.Sheets(1).Name = wb.Sheets(1).Range("j2") Else Set a2 = wb.Worksheets.Add f.Copy a2.Range("a1") a2.Name = a2.Range("j2") End If Loop Until s = 5 wb.SaveAs "v:\wuyou\" & n & ".xlsx" wb.Close savechanges:=True s = 0 n = n - 1 Next Sheets("nihao").AutoFilterMode = False [z:z].Delete MsgBox "恭喜你，已完成！！" End Sub----写这个可费了大麻烦,历经多次f8逐行运行,历经千辛万苦,终于试验出来了,总的来说,这是一个for里边增加一个do循环,本想用for循环嵌套,可无论怎么嵌套都不行,最后几经摸索,发现for循环里边再来个do循环可以满足我的要求,for循环在外边,do循环在里边,do循环完我要求的数量后,再新增工作簿,外边的变量继续累加循环,里边的变量要从0开始再循环①是新建的工作簿会自动有一个sheet1工作表,我需要把这个工作表利用起来,也就是一开始不能新增工作表,直接复制,并且改一下这个工作表的名字②然后再新增4个工作表,使每个工作簿达到5个工作表,然后保存关闭,,其实这样写有个麻烦,随着n的增加,最后一次会达不到5个,那么s的值将永不会是5,会陷入死循环. ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub 合并某文件夹下工作簿含多个工作表法1()
Dim s$, a As Workbook, b As Workbook
s = Dir("V:\wuyou\")
Set a = Workbooks.Add
Do
Set b = Workbooks.Open("V:\wuyou\" & s)
n = b.Worksheets.Count
For x = 1 To n
a.Activate
y = a.Sheets(1).UsedRange.Rows.Count
If y = 1 Then
b.Sheets(x).UsedRange.Copy a.Sheets(1).Cells(1, 1)
Else
b.Sheets(x).UsedRange.Copy a.Sheets(1).Cells(y + 1, 1)
Rows(y + 1).Delete
End If
Next x
b.Close savechanges:=False
s = Dir
Loop Until s = ""
MsgBox "恭喜,已全部合并完成"
End Sub '这种方法,
-----------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub 合并某文件夹下工作簿含多个工作表法2()
Dim s$, a As Workbook, b As Workbook
s = Dir("V:\wuyou\")
Set a = Workbooks.Add
Do
Set b = Workbooks.Open("V:\wuyou\" & s)
n = b.Worksheets.Count
For x = 1 To n
a.Activate
y = a.Sheets(1).UsedRange.Rows.Count
If y = 1 Then
b.Sheets(x).UsedRange.Copy a.Sheets(1).Cells(y, 1)
Else
b.Sheets(x).UsedRange.Copy a.Sheets(1).Cells(y + 1, 1)
End If
Next x
b.Close savechanges:=False
s = Dir
Loop Until s = ""
MsgBox "恭喜,已全部合并完成"
End Sub '这种方法,都用的表的可用区域,无删行,无论何种情况数据,都不会丢失行(usedrange一定要确保最前边几行不能空)
--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub 合并某文件夹下工作簿含多个工作表法3()
Dim s$, a As Workbook, b As Workbook
s = Dir("V:\wuyou\")
Set a = Workbooks.Add
Do
Set b = Workbooks.Open("V:\wuyou\" & s)
n = b.Worksheets.Count
For x = 1 To n
a.Activate
b.Worksheets(x).UsedRange.Copy a.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next x
b.Close savechanges:=False
s = Dir
Loop Until s = ""
MsgBox "恭喜,已全部合并完成"
End Sub '这种方法,定位的a列单元格从下往上找,再往下偏移一格进行复制,但衔接时正好a列有空的,复制会重复一行,无删除.
-----------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub 合并某文件夹下工作簿含多个工作表法4()
Dim s$, a As Workbook, b As Workbook
s = Dir("V:\wuyou\")
Set a = Workbooks.Add
Do
Set b = Workbooks.Open("V:\wuyou\" & s)
n = b.Worksheets.Count
For x = 1 To n
a.Activate
n1 = a.Sheets(1).Range("a1").CurrentRegion.Rows.Count
b.Worksheets(x).UsedRange.Copy a.Sheets(1).Cells(n1 + 1, 1)
Next x
b.Close savechanges:=False
s = Dir
Loop Until s = ""
MsgBox "恭喜,已全部合并完成"
End Sub
-------------------------------------------------------------------------------------------------------------------------------------------
Sub 合并某文件夹下工作簿含多个工作表法5()
Dim s$, a As Workbook, b As Workbook, y%, y1%
s = Dir("V:\wuyou\")
Set a = Workbooks.Add
Do
Set b = Workbooks.Open("V:\wuyou\" & s)
n = b.Worksheets.Count
For x = 1 To n
' a.Activate
'If Application.CountA(b.Worksheets(x).UsedRange.Cells) <> 0 Then 判断的是sheet表里是不是全是空的
If a.Sheets(1).[a1] = "" Then
b.Sheets(x).UsedRange.Copy a.Sheets(1).Cells(1, 1)
Else
If b.Worksheets(x).[a1] = a.Worksheets(1).[a1] And b.Worksheets(x).[b1] = a.Worksheets(1).[b1] _
And b.Worksheets(x).[c1] = a.Worksheets(1).[c1] And b.Worksheets(x).[d1] = a.Worksheets(1).[d1] Then
y = a.Sheets(1).UsedRange.Rows.Count + 1
b.Sheets(x).UsedRange.Copy a.Sheets(1).Cells(y, 1)
a.Sheets(1).Rows(y).Delete
Else
MsgBox "b工作簿" & x & "表里的四列第一行有问题": GoTo 100
End If
End If
Next x
b.Close savechanges:=False
s = Dir
Loop Until s = ""
MsgBox "恭喜,已全部合并完成"
100: End Sub '这个方法应该完美,只有第一次复制的时候不能判断abcd四列标题是否相等
|
IP卡
狗仔卡
发表于 2022-10-16 12:26:11
收藏
支持
反对
提升卡
沉默卡
喧嚣卡
变色卡
千斤顶
显身卡