VBA 批量处理Excel文件

目录

• [一. 批量创建Excel文件](#一. 批量创建Excel文件)
• • [1.1 VBA的方式](#1.1 VBA的方式)
  • [1.2 Powershell方式](#1.2 Powershell方式)
• [二. 批量删除文件](#二. 批量删除文件)
• [三. 批量重命名文件](#三. 批量重命名文件)
• [四. 合并多个Excel数据到一个Excel文件中](#四. 合并多个Excel数据到一个Excel文件中)

---

一. 批量创建Excel文件

1.1 VBA的方式

Sub CreateFiles()

    Dim strPath As String, strFileName As String
    Dim i As Long, r
    Dim pathSeparator As String
    On Error Resume Next
    
    ' 用户选择文件夹路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        ' 如果用户未选择文件夹则退出程序
        If .Show Then
            strPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    ' 给路径添加分隔符
    pathSeparator = Application.pathSeparator
    If Right(strPath, 1) <> pathSeparator Then
        strPath = strPath & pathSeparator
    End If
    
    ' 取消屏幕刷新
    Application.ScreenUpdating = False
    ' 取消警告提示，当有重名工作簿时直接覆盖
    Application.DisplayAlerts = False
    
    ' 数据装入数组r
    r = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    
    ' 标题不要，因此从第2个元素开始遍历数组r
    For i = 2 To UBound(r)
        ' 新建工作簿
        With Workbooks.Add
            ' 以指定名称、默认文件类型保存工作簿
            .SaveAs strPath & r(i, 1), xlWorkbookDefault
            ' 关闭工作簿
            .Close True
        End With
    Next
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "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-Null

    Write-Host "文件: ${fileName} ===> 创建完成!"  # 输出已创建的文件名
}

---

二. 批量删除文件

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

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

Sub GetFiles()

    Dim strPath As String
    Dim strFileName As String, k As Long
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        ' 获取用户选择的文件夹的路径，如果未选取，则退出程序
        If .Show Then 
            strPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    Application.ScreenUpdating = False
    
    If 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 + 1
        Cells(k, 1) = strPath & strFileName
        ' 第2次调用Dir函数，未使用任何参数，则获取同目录下的下一个文件名
        strFileName = Dir
    Loop
    
    Application.DisplayAlerts = True
    
End 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 Range
    Dim 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 If
    Next
    
    MsgBox "批量删除完成!"
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) 
    Next
    
    MsgBox "文件批量重命名完成!"
    
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 Worksheet
    Dim nTitleRow As Long, k As Long, nLastRow As Long
    Dim i As Long, j As Long, nStartRow As Long
    Dim aData, aResult, nStarRng As Long
    Dim strPath As String, strFileName As String
    Dim strKey As String, nShtCount As Long
    
    ' 获取用户选择的文件夹路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then 
            strPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

' /_/_/_/_/_/_/_/_/获取用户输入的数据Start/_/_/_/_/_/_/_/_/
    strKey = InputBox("请输入需要合并的工作表所包含的关键词：" & vbCrLf & "如未填写关键词，则默认汇总全部表格数据", "提醒")
    ' 如果点击了取消或者关闭按钮，则退出程序
    If StrPtr(strKey) = 0 Then
        Exit Sub
    End If
    
    nTitleRow = Val(InputBox("请输入标题的行数，默认标题行数为1", "提醒", 1))
    If nTitleRow < 0 Then
        MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
    End If
' /_/_/_/_/_/_/_/_/获取用户输入的数据End/_/_/_/_/_/_/_/_/
    
    Set shtActive = ActiveSheet
    With Application
        ' Excel 的屏幕刷新设置为 False
        ' 在执行后续操作时将不会看到屏幕上的更新，可以加快代码执行速度。
        .ScreenUpdating = False
        ' Excel 的显示警告设置为 False]
        ' 在执行后续操作时将不会显示警告框，比如保存文件时的覆盖提示等。
        .DisplayAlerts = False
        ' Excel 的更新链接时询问设置为 False
        ' 在打开包含链接的工作簿时将不会询问是否要更新链接。
        .AskToUpdateLinks = False
    End With
    
    ' 声明结果数组
    ReDim aResult(1 To 80000, 1 To 1)
    ' 清空当前表格数据
    Cells.ClearContents 
    ' 设置单元格为文本格式
    Cells.NumberFormat = "@"
    
    ' 补全路径
    If Right(strPath, 1) <> "\" Then
        strPath = 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)
                        ' 数据区域读入数组arr
                        aData = rng.Value
                        
                        ' 动态调整结果数组brr的最大列数
                        If UBound(aData, 2) + 2 > UBound(aResult, 2) Then
                            ReDim 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 Then
                            
                                With shtActive
                                    ' 获取放置来源数据的位置
                                    nLastRow = .Cells(Rows.Count, 1).End(xlUp).Row 
                                    ' 判断是否扣除标题行
                                    If nLastRow = 1 Then
                                        nStarRng = 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)) = aResult
                                    End If
                                End With
                                
                                k = 0
                                ' 重新设置结果数组
                                ReDim aResult(1 To UBound(aResult), 1 To UBound(aResult, 2))
                            End If
                            
                        Next
                    End If
                End If
            Next
            .Close False '关闭工作簿
        End With
        
        ' 继续下一个excel文件
        strFileName = Dir
    Loop
    
    If k > 0 Then
    
        ' 激活汇总表
        shtActive.Select 
        ' 放置数据的位置
        nLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        
        ' 如果汇总表数据为空，说明需要汇总的数据没有超过结果数组的上限
        If nLastRow = 1 Then
             nStarRng = 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)) = aResult
         End If
         
    End If
    
    ' 更新Excel的设置
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .AskToUpdateLinks = True
    End With
    
    MsgBox "一共汇总完成。" & nShtCount & "个工作表!", , "提示"
    
End Sub