使用vba把一个工作簿的多个sheet拆分成两个sheet为一个工作簿的多个工作簿

程序员汐

已于 2022-12-29 09:46:38 修改

阅读量2k

点赞数 1

分类专栏： VBA 文章标签： vba

于 2022-01-20 14:57:12 首次发布

本文链接：https://blog.csdn.net/xi5214/article/details/122601779

版权

VBA 专栏收录该内容

3 篇文章 0 订阅

订阅专栏

假如一个工作簿有10个sheet，一下代码就是把10个sheet拆分成两个工作簿，一个工作簿有2个sheet，并且包含原sheet的数据

Sub SplitWorksheet()
'定义对话框变量
Dim cc As FileDialog
Set cc = Application.FileDialog(msoFileDialogFilePicker)
Dim newwork As Workbook
Dim num As Integer
With cc
    If .Show = -1 Then
        Dim vrtSelectedItem As Variant
        For Each vrtSelectedItem In .SelectedItems
            Dim tempwb As Workbook
            Set tempwb = Workbooks.Open(vrtSelectedItem)
            
            '获取需拆分文件的工作表数量
            num = tempwb.Sheets.Count
            '获取需拆分文件的路径
            ipath = tempwb.Path & "\"
            
            For i = 1 To num
                
                '如果对2取余为0，执行以下代码
                If (i Mod 2 = 0) Then
                    
                    Set sht = Worksheets(i - 1)
                    '新建一个新的工作簿
                    Set newwork = Workbooks.Add
                    
                    '把需拆分的第一个工作簿的奇数工作表工作表复制到第二个工作簿的第一个sheet
                    tempwb.Worksheets(i - 1).Copy before:=newwork.Worksheets(1)
                    '把需拆分的第一个工作簿的偶数工作表工作表复制到第二个工作簿的第一个sheet
                    tempwb.Worksheets(i).Copy before:=newwork.Worksheets(2)
                    
                    '不知道什么原因，第一个工作簿的sheet会出现一点小问题，没有具体调查
                    '只是使用了一个方法去解决
                    
                    '把第三个sheet名修改成别的名字
                    '第一个sheet名需取拆分文件的第一个sheet名
                    If (i <= 2) Then
                        Worksheets(3).Name = "sheet3"
                        Worksheets(1).Name = sht.Name
                    End If

                    
                    '关闭弹框
                    Application.DisplayAlerts = Fals
                    
                    '保存文件到某个路径，和文件名 xlsx格式 加上下面注释的,True为xls格式
                    
                    ActiveWorkbook.SaveAs ipath & sht.Name ',True
                    
                    '删除第三个sheet
                    Sheets(newwork.Worksheets(3).Name).Delete
                    
                    '关闭指定工作簿
                    Workbooks(newwork.Name).Close savechanges:=True
                End If
            Next i
            tempwb.Close savechanges:=False
            MsgBox "工作表已拆分完毕到  " & ipath & "    路径下，请确认！"
        Next vrtSelectedItem
    End If
End With
Set cc = Nothing

End Sub