批量Excel 多个工作簿合并、拆分分成多个工作表vba代码

以下是一个将多个工作簿合并到一个工作表的VBA代码：

Sub MergeWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long

    ' Change this to the path\folder location of your files.
    MyPath = "C:\MyDocuments\"

    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    ' Set the file filter to find Excel files.
    FilesInPath = "*.xlsx*"

    ' Set the first result file number to 0.
    FNum = 0

    ' Loop through all files in the folder.
    If Dir(MyPath & FilesInPath) = "" Then
        MsgBox "No files found."
        Exit Sub
    End If

    ' Turn off calculation and screen updating.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    ' Set the base worksheet for the merge.
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

    ' Loop through all files.
    Do While Dir(MyPath & FilesInPath) <> ""
        ' Add to the file count.
        FNum = FNum + 1

        ' Re-dimension the array to hold the new file name.
        ReDim Preserve MyFiles(1 To FNum)

        ' Store the file name.
        MyFiles(FNum) = Dir(MyPath & FilesInPath)

        ' Go to the next file name.
        DirCount = DirCount + 1
        Dir

    Loop

    ' Set the starting row for the copy.
    rnum = 1

    ' Loop through all files and worksheets, copying the data to the base worksheet.
    For FNum = 1 To UBound(MyFiles)
        Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
        For Each sourceSheet In mybook.Worksheets
            ' Find the last row of data on the source worksheet.
            SourceRcount = sourceSheet.Cells(Rows.Count, "A").End(xlUp).Row

            ' Set the source range.
            Set sourceRange = sourceSheet.Range("A1:Z" & SourceRcount)

            ' Copy the data to the base worksheet.
            Set destrange = BaseWks.Range("A" & rnum)
            sourceRange.Copy destrange

            ' Increase the row counter.
            rnum = rnum + SourceRcount

        Next sourceSheet
        mybook.Close savechanges:=False
    Next FNum

    ' Turn on calculation and screen updating.
    With Application
        .Calculation = CalcMode
        .ScreenUpdating = True
    End With

    ' Auto-fit the columns on the base worksheet.
    BaseWks.Columns.AutoFit

End Sub

以下是将工作表拆分为多个工作簿的VBA代码：

Sub SplitWorkbook()
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim xWs As Worksheet
    Dim xWb As Workbook
    Dim FolderName As String
    Dim Lrow As Long
    Dim OutFolder As String

    ' Change this to the path\folder location where you want to save the new files.
    OutFolder = "C:\MyDocuments\"

    ' Create a new folder for the output files.
    If Len(Dir(OutFolder, vbDirectory)) = 0 Then
        MkDir OutFolder
    End If

    ' Only save the active sheet.
    Set xWs = Application.ActiveSheet

    ' Get the file extension and format number.
    FileExtStr = ".xlsx"
    FileFormatNum = 51

    ' Find the last row of data on the active sheet.
    Lrow = xWs.Cells(xWs.Rows.Count, "A").End(xlUp).Row

    ' Turn off calculation and screen updating.
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ' Loop through each row of data and save each row to a new file.
    For i = 2 To Lrow
        ' Create a new workbook.
        Set xWb = Application.Workbooks.Add

        ' Save the new workbook to the output folder.
        FolderName = OutFolder & xWs.Cells(i, "A").Value & FileExtStr

        ' Save the active sheet to the new workbook in the output folder.
        xWs.Rows(i).Copy
        xWb.Worksheets(1).Range("A1").PasteSpecial xlPasteAll

        ' Save and close the new workbook.
        xWb.SaveAs FolderName, FileFormatNum
        xWb.Close False
    Next i

    ' Turn on calculation and screen updating.
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

注意，这些代码应该修改以适应您的具体情况。