PDF转Excel:高效去除AI特征,实现数据自由编辑
560
2022-10-07
将指定文件夹中所有工作簿里的数据合并到同一工作表中
本文为《别怕,Excel VBA其实很简单(第3版)》随书问题参-
如果要合并数据的工作簿保存在代码所在目录下,名为“我的文件”的文件夹中,要合并这些文件中第一张工作表的数据,可以用下面的过程:
Sub 合并多工作簿第一张表的数据() Application.ScreenUpdating = False Dim DataArr As Variant, DataWb As Workbook, DataSht As Worksheet Dim EndRow As Long, ToSht As Worksheet, ToRng As Range Dim FileName As String '要合并的工作簿名称 Dim a As Long, b As Long Set ToSht = ThisWorkbook.Worksheets(1) ToSht.Rows("2:1048576").Clear '清除原有数据 FileName = Dir(ThisWorkbook.Path & "\我的文件\*.xls?") Do While FileName <> "" Workbooks.Open FileName:=ThisWorkbook.Path & "\我的文件\" & FileName Set DataWb = ActiveWorkbook Set DataSht = DataWb.Worksheets(1) EndRow = DataSht.Range("A1048576").End(xlUp).Row DataArr = DataSht.Range("A2").Resize(EndRow - 1, 8).Value Set ToRng = ToSht.Range("A1048576").End(xlUp).Offset(1, 0) For a = 1 To UBound(DataArr, 1) '将数组中超过15位的数字转为文本 For b = 1 To UBound(DataArr, 2) If Len(DataArr(a, b)) > 15 Then DataArr(a, b) = "'" & DataArr(a, b) End If Next b Next a ToRng.Resize(UBound(DataArr, 1), 8).Value = DataArr DataWb.Close savechanges:=False FileName = Dir Loop Application.ScreenUpdating = True MsgBox "合并完成!"End Sub
如果工作簿中保存了多张工作表,要合并所有工作表中的数据,过程可以改写为:
Sub 合并多工作簿所有工作表的数据() Application.ScreenUpdating = False Dim DataArr As Variant, DataWb As Workbook, DataSht As Worksheet Dim EndRow As Long, ToSht As Worksheet, ToRng As Range Dim FileName As String '要合并的工作簿名称 Dim a As Long, b As Long Set ToSht = ThisWorkbook.Worksheets(1) ToSht.Rows("2:1048576").Clear '清除原有数据 FileName = Dir(ThisWorkbook.Path & "\我的文件\*.xls?") Do While FileName <> "" Workbooks.Open FileName:=ThisWorkbook.Path & "\我的文件\" & FileName Set DataWb = ActiveWorkbook For Each DataSht In DataWb.Worksheets EndRow = DataSht.Range("A1048576").End(xlUp).Row DataArr = DataSht.Range("A2").Resize(EndRow - 1, 8).Value Set ToRng = ToSht.Range("A1048576").End(xlUp).Offset(1, 0) For a = 1 To UBound(DataArr, 1) '将数组中超过15位的数字转为文本 For b = 1 To UBound(DataArr, 2) If Len(DataArr(a, b)) > 15 Then DataArr(a, b) = "'" & DataArr(a, b) End If Next b Next a ToRng.Resize(UBound(DataArr, 1), 8).Value = DataArr Next DataSht DataWb.Close savechanges:=False FileName = Dir Loop Application.ScreenUpdating = True MsgBox "合并完成!"End Sub
你发现第二个过程在第一个过程的基础上,改动了哪些地方吗?
版权声明:本文内容由网络用户投稿,版权归原作者所有,本站不拥有其著作权,亦不承担相应法律责任。如果您发现本站中有涉嫌抄袭或描述失实的内容,请联系我们jiasou666@gmail.com 处理,核实后本网站将在24小时内删除侵权内容。