Excel工作簿拆分及合并

首先要说

HLAMaster 软件在导入数据时，要求一个 Excel 工作簿中只包含一条曲线，但有时候会出现以下这些情况：

• 一个工作簿中有多个表格（Sheet），每个表格中一条滞回曲线
• 一个工作簿中有一个表格，但这个表格中有多条滞回曲线
• …
  要把这些曲线一条条手动粘贴复制到新的工作簿中，也是一件麻烦事。因此，我写了一段 VBA 代码，来实现 Excel 工作簿的拆分与合并，用 Excel 自带的开发工具就可以完成，不需要额外安装什么插件。
  建议在使用前备份原始数据！
  建议在使用前备份原始数据!
  建议在使用前备份原始数据!

拆分工作簿

情况 1

针对第一种情况：一个工作簿中有多个表格（Sheet），每个表格中一条滞回曲线，可以用以下代码来实现工作簿的拆分，拆分后的文件保存在当前工作簿所在的文件夹内。

Sub SplitWorkbookIntoMultipleWorkbooks()
    Dim SourceWorkbook As Workbook
    Dim DestinationWorkbook As Workbook
    Dim ws As Worksheet
    Dim SavePath As String
    Dim i As Long
    '设置源工作簿，即当前工作簿
    Set SourceWorkbook = ActiveWorkbook
    '设置保存路径为当前工作簿所在目录
    SavePath = SourceWorkbook.Path & "\"
    '关闭屏幕更新，加速执行过程
    Application.ScreenUpdating = False
    '禁用删除工作表时弹出的确认对话框
    Application.DisplayAlerts = False
    '循环处理所有工作表
    For Each ws In SourceWorkbook.Worksheets
        '创建新的工作簿
        Set DestinationWorkbook = Workbooks.Add
        '复制当前工作表到新工作簿
        ws.Copy Before:=DestinationWorkbook.Sheets(1)
        '删除新工作簿中的其他工作表
        For i = DestinationWorkbook.Worksheets.Count To 2 Step -1
            DestinationWorkbook.Worksheets(i).Delete
        Next i
        '保存新工作簿
        DestinationWorkbook.SaveAs SavePath & ws.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        '关闭新工作簿
        DestinationWorkbook.Close 
    Next ws
    '恢复删除工作表时弹出的确认对话框
    Application.DisplayAlerts = True
    '恢复屏幕更新并提示完成
    Application.ScreenUpdating = True
    MsgBox "拆分完成！"
End Sub

具体操作步骤和效果，可以看以下演示动画（不会打开开发者工具的认真看!）：

情况 2

针对第 2种情况：一个工作簿中仅有一个表格，但这个表格中有多条滞回曲线，这种情况就需要规定下格式了，要求第 1、2 列为第 1 条曲线，第 3、4列为第 2 条曲线，第 5、6 列为第 3 条曲线…，依次类推，数据保持连续，相信聪明的你能明白！
格式规定好后，同样的打开开发者工具，新建一个模块，运行以下代码，就可以将这些曲线保存成单个的工作簿了。
注意：请在运行前确保源工作簿只有一张表格（删除无关的表格），且数据是连续的 (行方向、列方向都是连续的)。同时建议在操作前备份原始数据。

Sub SplitColumnsIntoMultipleWorkbooks()
    Dim SourceWorkbook As Workbook
    Dim SavePath As String
    Dim ws As Worksheet
    Dim i As Long
    Dim j As Long
    Dim DestinationWorkbook As Workbook
    Dim NewSheet As Worksheet
    '设置源工作簿，即当前工作簿
    Set SourceWorkbook = ActiveWorkbook
    '设置保存路径为当前工作簿所在目录
    SavePath = SourceWorkbook.Path & "\"
    '关闭屏幕更新，加速执行过程
    Application.ScreenUpdating = False
     '禁用删除工作表时弹出的确认对话框
    Application.DisplayAlerts = False
    '循环处理每一对列
    For j = 1 To SourceWorkbook.Worksheets(1).UsedRange.Columns.Count Step 2
        '创建新的工作簿
        Set DestinationWorkbook = Workbooks.Add
        '循环处理所有工作表
        For Each ws In SourceWorkbook.Worksheets
            With ws
                '在新工作簿中添加工作表
                DestinationWorkbook.Worksheets.Add After:=DestinationWorkbook.Sheets(DestinationWorkbook.Sheets.Count)
                '获取新添加的工作表
                Set NewSheet = DestinationWorkbook.Sheets(DestinationWorkbook.Sheets.Count)
                '复制第j列到新工作表的第1列
                .Columns(j).Copy Destination:=NewSheet.Cells(1, 1)
                '复制第j+1列到新工作表的第2列
                .Columns(j + 1).Copy Destination:=NewSheet.Cells(1, 2)
            End With
        Next ws
        '删除新工作簿中的第一个工作表
        DestinationWorkbook.Worksheets(1).Delete
        '保存新工作簿
        DestinationWorkbook.SaveAs SavePath & "工作簿" & (j + 1) / 2 & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        '关闭新工作簿
        DestinationWorkbook.Close
    Next j
    '恢复屏幕更新并提示完成
    Application.ScreenUpdating = True
    '恢复删除工作表时弹出的确认对话框
    Application.DisplayAlerts = True
    MsgBox "拆分完成！"
End Sub

具体操作步骤和效果，可以看以下演示动画：

合并工作簿

分分合合，咋能只有拆分，没有合并呢，对吧。
以下代码可以实现将多个工作簿合并成一个工作簿，一个工作簿中可能存在多个工作表的情况，如果不同工作簿中的工作表存在名字相同的情况也进行了考虑，可以处理。运行代码后合并的工作簿将保存在当前工作簿所在的文件夹。（嗯，你要运行下面的代码，就必须打开一个工作簿，当前工作簿就是指的这个工作簿）

Sub MergeSelectedWorkbooks()
    Dim SourceFolder As String
    Dim TargetWorkbook As Workbook
    Dim SourceWorkbook As Workbook
    Dim SourceSheet As Worksheet
    Dim TargetSheet As Worksheet
    Dim File As Variant
    Dim NewSheetName As String
     '设置源工作簿，即当前工作簿
    Set SourceNowWorkbook = ActiveWorkbook
    '设置保存路径为当前工作簿所在目录
    SavePath = SourceNowWorkbook.Path & "\"
    '打开文件选择对话框，选择需要合并的多个工作簿
    With Application.FileDialog(msoFileDialogOpen)
        .Title = "选择需要合并的工作簿"
        .Filters.Clear
        .Filters.Add "Excel文件", "*.xls;*.xlsx;*.xlsm"
        .AllowMultiSelect = True
        
        If .Show = -1 Then
            '获取选择的文件路径和名称
            For Each File In .SelectedItems
                '打开源工作簿
                Set SourceWorkbook = Workbooks.Open(File)
                
                '创建目标工作簿（如果还没有）
                If TargetWorkbook Is Nothing Then
                    Set TargetWorkbook = Workbooks.Add
                End If
                
                '复制每个工作表到目标工作簿中，可以根据需要修改复制位置
                For Each SourceSheet In SourceWorkbook.Sheets
                    '检查目标工作簿中是否已存在同名工作表
                    NewSheetName = SourceSheet.Name
                    If SheetExists(TargetWorkbook, NewSheetName) Then
                        '如果存在，则修改新工作表的名称
                        NewSheetName = GetUniqueSheetName(TargetWorkbook, NewSheetName)
                    End If
                    
                    '在目标工作簿中创建新工作表，名称为NewSheetName
                    Set TargetSheet = TargetWorkbook.Sheets.Add(After:=TargetWorkbook.Sheets(TargetWorkbook.Sheets.Count))
                    TargetSheet.Name = NewSheetName
                    
                    '复制源工作表数据到目标工作表
                    SourceSheet.UsedRange.Copy Destination:=TargetSheet.Range("A1")
                Next SourceSheet
                
                '关闭源工作簿
                SourceWorkbook.Close SaveChanges:=False
            Next File
            
            '保存目标工作簿
            TargetWorkbook.SaveAs SavePath & "合并工作簿.xlsx" '保存在当前工作簿所在文件夹
            
            '关闭目标工作簿
            TargetWorkbook.Close SaveChanges:=False
            
            MsgBox "工作簿合并完成！"
        Else
            MsgBox "未选择任何文件。"
        End If
    End With
End Sub

Function SheetExists(ByVal wb As Workbook, ByVal sheetName As String) As Boolean
    On Error Resume Next
    SheetExists = Not wb.Sheets(sheetName) Is Nothing
    On Error GoTo 0
End Function

Function GetUniqueSheetName(ByVal wb As Workbook, ByVal sheetName As String) As String
    Dim newSheetName As String
    Dim suffix As Integer
    
    newSheetName = sheetName
    suffix = 1
    
    Do While SheetExists(wb, newSheetName)
        suffix = suffix + 1
        newSheetName = sheetName & "_" & suffix
    Loop
    
    GetUniqueSheetName = newSheetName
End Function

具体操作步骤和效果，可以看以下演示动画：

插件

其实除了采用上面的 VBA 代码，还有很多优秀的 Excel 插件可以实现这样的功能，比如：

• 方方格子，官网： http://ffcell.com/

• KUTOOLS For Excel： https://www.extendoffice.com/

其实可以选择装个插件，以后处理 Excel 的时候能极大的提高工作效率，事半功倍，当然了，插件装多了容易造成加载较慢，个人还是习惯写 VBA 代码来解决实际问题。

---

不方便在这里分享这些插件，需要的可以联系我获取。