如何合并文件夹内多工作簿的有效数据行（整合花名册）

chenmeidi · 发表于 2012-3-8 23:13

花名册.rar (174.21 KB, 下载次数: 41) 求代码：如何合并文件夹内多工作簿的有效数据行（整合花名册）
1、多工作簿存放在同一个文件夹内，数目较多。
2、花名册的字段格式相同，但各表的花名册中间有空行，空行没有规律。
3、把文件夹内所有的花名册工作簿中的人员信息全部整合到同一份汇总花名册中，并自动重新编号。
花名册样式和汇总后的样式见附件

somalia · 发表于 2012-3-8 23:43

合并文件，一行里有个字段非空即为有效记录

szwzq · 发表于 2012-3-8 23:47

Sub tt()
Dim i%, k%, myfile$, nbook, ar, arr(1 To 65536, 1 To 21)
myfile = Dir(ThisWorkbook.Path & "")
Do While myfile <> ""
If myfile <> "汇总.xls" Then
Set nbook = CreateObject(ThisWorkbook.Path & "" & myfile)
With Workbooks(myfile).Sheets(1)
ar = .Range("a3:u" & .[a65536].End(3).Row)
End With
nbook.Close False
For i = 1 To UBound(ar)
If ar(i, 2) <> "" Then
k = k + 1
arr(k, 1) = k
For j = 2 To 21
arr(k, j) = ar(i, j)
Next
End If
Next
End If
myfile = Dir
Loop
With Sheet1
.Rows("3:65536").Clear
.[a3].Resize(k, 21) = arr
End With
End Sub

复制代码

chenmeidi · 发表于 2012-3-9 00:29

szwzq 发表于 2012-3-8 23:47

太感谢楼上的szwzq 大师了，这么短时间就给我帮助解决问题了，我试着编写了好几天，都没办法突破如何避开中间的无效数据行，您真是高效啊，就是身份证号码汇总后格式变了，后面出现乱码，能否再帮我完善一下，再次谢谢了。

zuiaidh2004 · 发表于 2012-3-9 10:53

路过学习。。

szwzq · 发表于 2012-3-9 12:28

Sub tt()
Dim i%, k%, myfile$, nbook, ar, arr(1 To 65536, 1 To 21)
Application.ScreenUpdating = False
myfile = Dir(ThisWorkbook.Path & "")
Do While myfile <> ""
If myfile <> "汇总.xls" Then
Set nbook = CreateObject(ThisWorkbook.Path & "" & myfile)
With Workbooks(myfile).Sheets(1)
ar = .Range("a3:u" & .[a65536].End(3).Row)
End With
nbook.Close False
For i = 1 To UBound(ar)
If ar(i, 2) <> "" Then
k = k + 1
arr(k, 1) = k
For j = 2 To 7
arr(k, j) = ar(i, j)
Next
arr(k, 8) = "'" & ar(i, 8)
For j = 9 To 21
arr(k, j) = ar(i, j)
Next
End If
Next
End If
myfile = Dir
Loop
With Sheet1
.Rows("3:65536").Clear
.[a3].Resize(k, 21) = arr
End With
Application.ScreenUpdating = True
End Sub

复制代码

chenmeidi · 发表于 2012-3-9 22:16

szwzq 发表于 2012-3-9 12:28

很感谢大师的悉心解答，本表已经完全符合我的要求了，太感谢了，珍藏着慢慢研究。还想再请教大师，能否把表格线及单元格格式和文字格式等全部复制过来，除公式以外。因为有些人喜欢把日期格式用小数点来分割，如：文本格式“1985.10“表示1985年10月，当复制过来时可能只剩下”1985.1“

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

[求助] 如何合并文件夹内多工作簿的有效数据行（整合花名册）