VBA 批量处理Excel文件

---

一. 批量创建Excel文件

1.1 VBA的方式

Sub CreateFiles()Dim strPath As String, strFileName As StringDim i As Long, rDim pathSeparator As StringOn Error Resume Next' 用户选择文件夹路径With Application.FileDialog(msoFileDialogFolderPicker)' 如果用户未选择文件夹则退出程序If .Show ThenstrPath = .SelectedItems(1)ElseExit SubEnd IfEnd With' 给路径添加分隔符pathSeparator = Application.pathSeparatorIf Right(strPath, 1) <> pathSeparator ThenstrPath = strPath & pathSeparatorEnd If' 取消屏幕刷新Application.ScreenUpdating = False' 取消警告提示，当有重名工作簿时直接覆盖Application.DisplayAlerts = False' 数据装入数组rr = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)' 标题不要，因此从第2个元素开始遍历数组rFor i = 2 To UBound(r)' 新建工作簿With Workbooks.Add' 以指定名称、默认文件类型保存工作簿.SaveAs strPath & r(i, 1), xlWorkbookDefault' 关闭工作簿.Close TrueEnd WithNextApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueMsgBox "Excel批量创建完成。"
End Sub

1.2 Powershell方式

# 指定要创建的文件数量
$excelCount = 5
# 指定文件名前缀
$fileNamePrefix = "Excel文件"# 循环创建指定数量的 Excel 文件
1..$excelCount | ForEach-Object {# 设置文件名，这里使用 .xlsx 格式$fileName = "${fileNamePrefix}_$_.xlsx" # 获取文件路径$filePath = Join-Path -Path $PWD -ChildPath $fileName  # 创建 Excel 工作簿并保存$excel = New-Object -ComObject Excel.Application$workbook = $excel.Workbooks.Add()$workbook.SaveAs($filePath)$workbook.Close()$excel.Quit()<#用来显式释放 Excel COM 对象的资源，以确保在脚本执行完成后，释放 Excel 进程和相关资源，避免资源泄漏和占用问题。使用 Out-Null 可以将输出结果丢弃，避免将释放对象的消息输出到控制台。#>[System.Runtime.Interopservices.Marshal]::ReleaseComObject($excel) | Out-NullWrite-Host "文件: ${fileName} ===> 创建完成!"  # 输出已创建的文件名
}

---

二. 批量删除文件

⏹获取指定文件夹下的文件

• Range("A:B").Clear: k = 1
  • :：冒号在 VBA 中用来分隔两条语句，表示同时执行两个操作。
• strFileName = Dir
  • 获取下一个文件的文件名，通过这个操作，实现了遍历文件夹中的所有文件。

Sub GetFiles()Dim strPath As StringDim strFileName As String, k As LongWith Application.FileDialog(msoFileDialogFolderPicker)' 获取用户选择的文件夹的路径，如果未选取，则退出程序If .Show Then strPath = .SelectedItems(1)ElseExit SubEnd IfEnd WithApplication.ScreenUpdating = FalseIf Right(strPath, 1) <> "\" Then strPath = strPath & "\"End If' 清除A:B列的所有数据Range("A:B").Clear: k = 1' 向A1,B1列填入数据Cells(1, 1) = "旧文件名": Cells(1, 2) = "是否删除"' 获取指定路径下的文件(通配符获取首个文件名)strFileName = Dir(strPath & "*.xls*")Do While strFileName <> ""k = k + 1Cells(k, 1) = strPath & strFileName' 第2次调用Dir函数，未使用任何参数，则获取同目录下的下一个文件名strFileName = DirLoopApplication.DisplayAlerts = TrueEnd Sub

⏹删除文件

• Set dataRange = Range("A1").CurrentRegion
  • 用于获取指定单元格的当前区域的语法。
  • 返回一个表示当前区域的 Range 对象，该区域是从指定单元格开始向右和向下延伸到包含数据的边界。
  • 在此案例中，数据结构如下

  [["旧文件名", "是否删除"],["文件路径1", "删除"],["文件路径2", "删除"]......
  ]
  

• Dir(dataRange(i, 1)) <> ""
  • Dir 是一个 VBA 中用于操作文件系统的函数。
  • 主要用于检查文件或目录是否存在，以及获取目录中的文件和子目录列表。
• Kill dataRange(i, 1)：VBA 中用于删除文件或目录的语句。它可以用来删除指定路径下的文件或目录。

Sub DeleteFile()Dim dataRange As RangeDim i As Long' 数据装入数组Set dataRange = Range("A1").CurrentRegion' 标题行不要，从数组第二行开始遍历For i = 2 To dataRange.Rows.Count' 如果第2列为删除,并且要删除的文件存在的话,才会执行删除命令If dataRange(i, 2) = "删除" And Dir(dataRange(i, 1)) <> "" Then' Kill语句删除指定文件Kill dataRange(i, 1)End IfNextMsgBox "批量删除完成!"
End Sub

---

三. 批量重命名文件

• Name r(i, 1) As r(i, 2):将A2单元格中的文件，重命名为B2单元格中的文件名
  • 在 VBA 中，Name 关键字用于重命名文件或文件夹。
  • Name "文件绝对路径1" As "文件绝对路径2"

Sub ChangeFileName()Dim r, i As Long' 数据装入数组r = Range("A1").CurrentRegion ' 标题行不要，从数组第二行开始遍历For i = 2 To UBound(r)' Name语句重命名Name r(i, 1) As r(i, 2) NextMsgBox "文件批量重命名完成!"End Sub

---

四. 合并多个Excel数据到一个Excel文件中

• Val(InputBox("请输入标题的行数，默认标题行数为1", "提醒", 1))
  • Val函数可以将数字字符串转换为数字
• With GetObject(strPath & strFileName)
  • 只读形式读取文件时，使用getobject会比workbooks.open稍快
• Exit Do：跳出本次Do while循环，相当于continue的效果。
• .Range("A1:B1") = Array("来源工作簿名称", "来源工作表名称")：同时向A1，B1单元格赋值。
• IIf(nTitleRow = 0, 1, 0)：IIf(条件, 真时返回的值, 假时返回的值)
• InStr(1, shtData.Name, strKey, vbTextCompare)：InStr函数，用于在一个字符串中查找另一个字符串，并返回第一个匹配的位置。
  • 1：指定搜索的起始位置，这里是从字符串的第一个字符开始搜索。
  • shtData.Name：待被搜索的字符串。
  • strKey：要查找的子字符串(从shtData.Name中查找strKey)。
  • vbTextCompare：指定比较方式，这里使用文本比较，表示不区分大小写进行比较。

Sub CollectWorkBookDatas()Dim shtActive As Worksheet, rng As Range, shtData As WorksheetDim nTitleRow As Long, k As Long, nLastRow As LongDim i As Long, j As Long, nStartRow As LongDim aData, aResult, nStarRng As LongDim strPath As String, strFileName As StringDim strKey As String, nShtCount As Long' 获取用户选择的文件夹路径With Application.FileDialog(msoFileDialogFolderPicker)If .Show Then strPath = .SelectedItems(1)ElseExit SubEnd IfEnd With' /_/_/_/_/_/_/_/_/获取用户输入的数据Start/_/_/_/_/_/_/_/_/strKey = InputBox("请输入需要合并的工作表所包含的关键词：" & vbCrLf & "如未填写关键词，则默认汇总全部表格数据", "提醒")' 如果点击了取消或者关闭按钮，则退出程序If StrPtr(strKey) = 0 ThenExit SubEnd IfnTitleRow = Val(InputBox("请输入标题的行数，默认标题行数为1", "提醒", 1))If nTitleRow < 0 ThenMsgBox "标题行数不能为负数。", 64, "警告": Exit SubEnd If
' /_/_/_/_/_/_/_/_/获取用户输入的数据End/_/_/_/_/_/_/_/_/Set shtActive = ActiveSheetWith Application' Excel 的屏幕刷新设置为 False' 在执行后续操作时将不会看到屏幕上的更新，可以加快代码执行速度。.ScreenUpdating = False' Excel 的显示警告设置为 False]' 在执行后续操作时将不会显示警告框，比如保存文件时的覆盖提示等。.DisplayAlerts = False' Excel 的更新链接时询问设置为 False' 在打开包含链接的工作簿时将不会询问是否要更新链接。.AskToUpdateLinks = FalseEnd With' 声明结果数组ReDim aResult(1 To 80000, 1 To 1)' 清空当前表格数据Cells.ClearContents ' 设置单元格为文本格式Cells.NumberFormat = "@"' 补全路径If Right(strPath, 1) <> "\" ThenstrPath = strPath & "\"End If' 使用Dir函数遍历excel文件strFileName = Dir(strPath & "*.xls*") Do While strFileName <> ""' 避免同名文件重复打开出错If strFileName = ThisWorkbook.Name Then ' 继续下一个excel文件strFileName = Dir ' 跳出本次While循环Exit Do End If' 以只读形式读取文件时，使用getobject会比workbooks.open稍快With GetObject(strPath & strFileName)' 遍历Excel中的各sheet页For Each shtData In .Worksheets ' 如果表中包含关键字则进行汇总(不区分关键词字母大小写）If InStr(1, shtData.Name, strKey, vbTextCompare) Then' 获取sheet页中的使用区域Set rng = shtData.UsedRange' 判断工作表是否存在数据If rng.Count > 1 Then' 汇总工作表的数量nShtCount = nShtCount + 1 ' 判断遍历数据源是否应该扣掉标题行nStartRow = IIf(nShtCount = 1, 1, nTitleRow + 1)' 数据区域读入数组arraData = rng.Value' 动态调整结果数组brr的最大列数If UBound(aData, 2) + 2 > UBound(aResult, 2) ThenReDim Preserve aResult(1 To UBound(aResult), 1 To UBound(aData, 2) + 2)End If' 遍历行For i = nStartRow To UBound(aData)k = k + 1' 数组第一列放工作簿名称aResult(k, 1) = strFileName' 数组第二列放工作表名称aResult(k, 2) = shtData.Name' 遍历列For j = 1 To UBound(aData, 2)aResult(k, j + 2) = aData(i, j)Next' 如果数据行数到达结果数组的上限，则将数据导入汇总表，并清空结果数组If k > UBound(aResult) - 1 ThenWith shtActive' 获取放置来源数据的位置nLastRow = .Cells(Rows.Count, 1).End(xlUp).Row ' 判断是否扣除标题行If nLastRow = 1 ThennStarRng = IIf(nTitleRow = 0, 1, 0).Range("A1").Offset(nStarRng).Resize(k, UBound(aResult, 2)) = aResult' 前两列放来源工作簿和工作表名称.Range("A1:B1") = Array("来源工作簿名称", "来源工作表名称")Else' 放结果数组的数据.Range("A1").Offset(nLastRow).Resize(k, UBound(aResult, 2)) = aResultEnd IfEnd Withk = 0' 重新设置结果数组ReDim aResult(1 To UBound(aResult), 1 To UBound(aResult, 2))End IfNextEnd IfEnd IfNext.Close False '关闭工作簿End With' 继续下一个excel文件strFileName = DirLoopIf k > 0 Then' 激活汇总表shtActive.Select ' 放置数据的位置nLastRow = Cells(Rows.Count, 1).End(xlUp).Row' 如果汇总表数据为空，说明需要汇总的数据没有超过结果数组的上限If nLastRow = 1 ThennStarRng = IIf(nTitleRow = 0, 1, 0)Range("a1").Offset(nStarRng).Resize(k, UBound(aResult, 2)) = aResultRange("a1:b1") = Array("来源工作簿名称", "来源工作表名称")ElseRange("a1").Offset(nLastRow).Resize(k, UBound(aResult, 2)) = aResultEnd IfEnd If' 更新Excel的设置With Application.ScreenUpdating = True.DisplayAlerts = True.AskToUpdateLinks = TrueEnd WithMsgBox "一共汇总完成。" & nShtCount & "个工作表!", , "提示"End Sub