VBA，拆分Excel工作表 如何用vba拆分excel表到新的工作簿

又找到一个小工具：

根据设置的参数，自动拆分工作表为多个工作簿文档。

主要代码，如：

Sub StartToSplit(strSavedPath As String, ByVal arrNewBookSheets As Variant)

    Dim i As Integer
    
    Dim wbNew As Workbook
    Dim strwbNewName As String
    Dim strwbNewFullName As String
        
    Dim strActiveBookBaseName As String
    strActiveBookBaseName = GetWorkbookBaseName()
    
    Dim strNewSheets As String
    strNewSheets = GetAllCheckedItemsName(Me.ListView1)
    
    intMaxLen = Len(CStr(UBound(arrNewBookSheets)))
    
    Application.ScreenUpdating = False
    
    Dim strSplitFieldValue As String
    
    For i = LBound(arrNewBookSheets) To UBound(arrNewBookSheets)
    
        strSplitFieldValue = arrNewBookSheets(i)
        
        '遇到空白单元格，直接跳出！
        If Len(Trim(strSplitFieldValue)) = 0 Then
            Exit Sub
        End If
 
        
        If Me.规则0.Value = True Then
            strwbNewName = FormatNumberWithLeadingZeros(i + 1, intMaxLen) & "：" & strSplitFieldValue & ".xlsx"
        End If
        
        If Me.规则1.Value = True Then
            strwbNewName = strActiveBookBaseName & "（" & strSplitFieldValue & "）" & ".xlsx"
        End If
        
        If Me.规则2.Value = True Then
            If Trim(Me.TextBox自定义名称.Text) = "" Then
                strwbNewName = strSplitFieldValue & ".xlsx"
            Else
                strwbNewName = CleanFileName(Trim(Me.TextBox自定义名称.Text)) & "（" & strSplitFieldValue & "）" & ".xlsx"
            End If
        End If
        
        '创建的工作簿，有副本？
        
        Set wbNew = CreateWorkbookWithSheets(strNewSheets)
        
        Dim strLines  As String
        strLines = GetAllCheckedItemsAsString(Me.ListView1)
        

        Call CopyLine(activeSourceWorkbook, strLines, strSplitFieldValue, wbNew)
        
        Dim objSheetAdded As Worksheet
        
        
        For Each objSheetAdded In wbNew.Worksheets
            
            objSheetAdded.Columns.AutoFit
        
        Next
        
        
        wbNew.SaveAs (strSavedPath + strwbNewName)
        Call wbNew.Close(True, strSavedPath + strwbNewName)
        Set wbNew = Nothing
  
    Next i
    
    Application.ScreenUpdating = True

End Sub

Sub CopyLine(ByVal wbSource As Workbook, ByVal strLines As String, ByVal strSplitFieldValue As String, ByVal wbDestination As Workbook)

    Dim lineArray() As String
    Dim detailArray() As String
    Dim strline As String
    Dim strName As String
    Dim intRow As Integer
    Dim intColumn As Integer
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    Dim copyRange As Range
    Dim cell As Range
    
    lineArray = Split(strLines, "|")
    
    For i = LBound(lineArray) To UBound(lineArray)
        strline = lineArray(i)
        detailArray = Split(strline, ";")
        
        If UBound(detailArray) >= 2 Then
        
            strName = detailArray(0)
            intRow = CInt(detailArray(1))
            intColumn = CInt(detailArray(2))
            
            Set wsSource = wbSource.Sheets(strName)
            Set wsDest = wbDestination.Sheets(strName)
            
            
            Set copyRange = wsSource.Range("A1").Resize(intRow - 1, wsSource.Columns.Count)
            copyRange.Copy
            wsDest.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
            

            lastRow = wsDest.Cells(wsDest.Rows.Count, intColumn).End(xlUp).Row + 1
            Dim hasFormula As Boolean
 
    
    
            For Each cell In wsSource.Range(wsSource.Cells(intRow, intColumn), wsSource.Cells(wsSource.Rows.Count, intColumn))
                If cell.Value = strSplitFieldValue Then
                    hasFormula = RowHasFormula(GetUsedCellsInRow2(cell.EntireRow))
                    
                    cell.EntireRow.Copy
                    wsDest.Cells(lastRow, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
                    If hasFormula Then
                        wsDest.Cells(lastRow, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    End If
            
                    wsSource.Rows(cell.Row).Copy
                    wsDest.Rows(lastRow).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            
                    lastRow = lastRow + 1
                End If
            Next cell
            Application.GoTo Reference:=wsDest.Cells(1, 1)
            Application.CutCopyMode = False


            
        End If
    Next i
End Sub



Function GetColumnValues(strSheetName As String, intStartRow As Integer, intSplitColumn As Integer) As Variant

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim values() As Variant
    Dim i As Long
 
    On Error Resume Next
    Set ws = activeSourceWorkbook.Worksheets(strSheetName)
    
    If ws Is Nothing Then
        GetColumnValues = Null
        Exit Function
    End If
    
    lastRow = ws.Cells(ws.Rows.Count, intSplitColumn).End(xlUp).Row
    
    If intStartRow > lastRow Then
        GetColumnValues = Null
        Exit Function
    End If
 
    ReDim values(1 To lastRow - intStartRow + 1)
    For i = intStartRow To lastRow
        values(i - intStartRow + 1) = ws.Cells(i, intSplitColumn).Value
    Next i
    GetColumnValues = values
    
End Function



Function GetFirstCheckedListViewItemValue(ByVal ListViewCtrl As ListView) As String
    Dim i As Integer
    For i = 1 To ListViewCtrl.ListItems.Count
        If ListViewCtrl.ListItems(i).Checked Then
            Dim checkedItem As ListItem
            Set checkedItem = ListViewCtrl.ListItems(i)
            GetFirstCheckedListViewItemValue = checkedItem.Text & ";" & checkedItem.ListSubItems(1).Text & ";" & checkedItem.ListSubItems(2).Text
            Exit Function
        End If
    Next i
    GetFirstCheckedListViewItemValue = ""
End Function


Function GetAllCheckedItemsName(ListViewCtrl As ListView) As String

    Dim i As Integer
    Dim result As String
    result = ""

    For i = 1 To ListViewCtrl.ListItems.Count
        If ListViewCtrl.ListItems(i).Checked Then
            result = result & ListViewCtrl.ListItems(i).Text & ";"
        End If
    Next i

    If Len(result) > 0 Then
        result = Left(result, Len(result) - 1)
    End If

    GetAllCheckedItemsName = result
    
End Function