vba批量处理excel初体验（合并工作表、拆分工作簿

概览

利用vba批量处理excel基础操作是：

1. 打开一个excel工作表，使用Alt+F11调出vba编辑器
2. 插入->模块
3. 使用Alt+F8运行

一.合并工作表

需求： 需要用vba批量处理excel文件，背景如下： 有一个文件夹，文件夹下有test01、test02两个excel工作簿，且这两个工作簿只有一个工作表，为Sheet1; 预期效果：希望创建一个新的工作簿，比如名称为mergeBook，希望该工作簿有两个工作表，表名分别为test01和test02,该工作表对应着原先test01、test02两个excel工作簿Sheet1工作表的内容

vba代码

Sub MergeWorksheets()
    Dim folderPath As String
    Dim fileName As String
    Dim sourceWorkbook As Workbook
    Dim targetWorkbook As Workbook
    Dim targetSheet As Worksheet
    
    ' 设置文件夹路径，请根据实际情况修改
    folderPath = "C:\YourFolderPath\" ' 替换为实际文件夹路径
    
    ' 检查文件夹是否存在，如果不存在则创建
    If Dir(folderPath, vbDirectory) = "" Then
        MkDir folderPath
    End If
    
    ' 创建新的工作簿 mergeBook
    Set targetWorkbook = Workbooks.Add
    
    On Error Resume Next ' 忽略可能的错误
    targetWorkbook.SaveAs Filename:=folderPath & "mergeBook.xlsx"
    If Err.Number <> 0 Then
        MsgBox "保存文件时出错，请检查文件夹路径和权限。错误代码: " & Err.Number
        Err.Clear
        On Error GoTo 0
        Exit Sub
    End If
    On Error GoTo 0 ' 恢复错误处理
    
    ' 获取文件夹中的第一个 Excel 文件
    fileName = Dir(folderPath & "*.xlsx")
    
    ' 循环遍历文件夹中的所有 Excel 文件
    Do While fileName <> ""
        ' 排除合并后的工作簿
        If fileName <> "mergeBook.xlsx" Then
            ' 打开源工作簿
            Set sourceWorkbook = Workbooks.Open(folderPath & fileName)
            
            ' 清理文件名，去除非法字符
            Dim validName As String
            validName = Replace(fileName, ".xlsx", "")
            validName = Replace(validName, "\", "")
            validName = Replace(validName, "/", "")
            validName = Replace(validName, "?", "")
            validName = Replace(validName, "*", "")
            validName = Replace(validName, "[", "")
            validName = Replace(validName, "]", "")
            ' 截断名称，确保不超过 31 个字符
            If Len(validName) > 31 Then
                validName = Left(validName, 31)
            End If
            
            ' 检查名称是否已存在，如果存在则添加序号
            Dim newName As String
            newName = validName
            Dim i As Integer
            i = 1
            Do While WorksheetExists(newName, targetWorkbook)
                newName = validName & " (" & i & ")"
                i = i + 1
            Loop
            
            ' 在目标工作簿中添加新的工作表
            Set targetSheet = targetWorkbook.Sheets.Add(After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count))
            targetSheet.Name = newName
            
            ' 复制源工作表的内容到目标工作表
            sourceWorkbook.Sheets("Sheet1").Cells.Copy targetSheet.Cells
            
            ' 关闭源工作簿
            sourceWorkbook.Close SaveChanges:=False
        End If
        
        ' 获取下一个 Excel 文件
        fileName = Dir
    Loop
    
    ' 保存并关闭目标工作簿
    targetWorkbook.Save
    targetWorkbook.Close
End Sub

Function WorksheetExists(sheetName As String, wb As Workbook) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Sheets(sheetName)
    WorksheetExists = Err.Number = 0
    Err.Clear
    On Error GoTo 0
End Function
    

二. 拆分工作表

需求： 比如有一个excel表有多个工作簿，希望把工作表的工作簿拆分出来，新建成excel工作表

代码如下：

Sub SplitWorksheetsIntoFiles()
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim newWB As Workbook
    Dim savePath As String
    
    ' 设置保存拆分后文件的路径，可根据实际情况修改
    savePath = "C:\YourSavePath\"
    
    ' 检查保存路径是否存在，若不存在则创建
    If Dir(savePath, vbDirectory) = "" Then
        MkDir savePath
    End If
    
    ' 获取当前工作簿
    Set wb = ThisWorkbook
    
    ' 遍历当前工作簿中的每个工作表
    For Each ws In wb.Sheets
        ' 创建一个新的工作簿
        Set newWB = Workbooks.Add
        
        ' 将当前工作表复制到新工作簿中
        ws.Copy Before:=newWB.Sheets(1)
        
        ' 删除新工作簿中默认创建的工作表
        Application.DisplayAlerts = False
        newWB.Sheets(2).Delete
        Application.DisplayAlerts = True
        
        ' 保存新工作簿，文件名使用原工作表名
        newWB.SaveAs Filename:=savePath & ws.Name & ".xlsx"
        
        ' 关闭新工作簿
        newWB.Close SaveChanges:=False
    Next ws
    
    MsgBox "工作表拆分完成！"
End Sub