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

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