VBA读取 Excel 并按工作表拆分成多个 Excel

新建窗体

Sub SplitExcelByMonth()

    'On Error GoTo ErrorHandler ' 启用错误处理
    On Error Resume Next
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
     
    Dim exclePath, sourceSheetName, groupSheetName, filterIndexInput, filterIndexNum, saveFolder, filePrefix, columnTemp

    Dim sourceWorkbook As Workbook
    Dim targetWorkbook As Workbook
    Dim filterSheet As Worksheet
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    Dim currentValue As String
    Dim targetWorkbookName As String
    
  
    exclePath = txt_exclePath.Text
    If exclePath = "" Then
        MsgBox "请输入文件完整路径"
        Exit Sub
    End If
    If Len(Dir$(exclePath)) = 0 Then
        MsgBox "所输件路径下的文件不存在"
        Exit Sub
    End If
    
    ' 打开源工作簿
    Set sourceWorkbook = Workbooks.Open(exclePath)

    
    groupSheetName = txt_groupSheetName.Text
    If groupSheetName = "" Then
        MsgBox "请输入分组工作簿名称"
        Exit Sub
    End If
    
    Dim sht As Worksheet
    Dim existsSheet As Long
    
    existsSheet = 0
    
    For Each sht In sourceWorkbook.Worksheets
       If sht.Name = groupSheetName Then
         existsSheet = 1
         Exit For
       End If
    Next

    If existsSheet = 0 Then
      MsgBox "分组工作簿名称不存在"
      Exit Sub
    End If
    
    'If Application.WorksheetFunction.CountA(filterSheet) = 0 Then
  
    sourceSheetName = txt_sourceSheetName.Text
    If sourceSheetName = "" Then
        MsgBox "请输入数据源工作簿名称"
        Exit Sub
    End If
    
    existsSheet = 0
    
    For Each sht In sourceWorkbook.Worksheets
       If sht.Name = sourceSheetName Then
         existsSheet = 1
         Exit For
       End If
    Next

    If existsSheet = 0 Then
      MsgBox "数据源工作簿名称不存在"
      Exit Sub
    End If
     
     
    filterIndexInput = txt_filterIndexInput.Text
    If filterIndexInput = "" Then
        MsgBox "请输入数据源工作簿中筛选列的顺序(第几列)"
        Exit Sub
    Else
        filterIndexNum = Int(filterIndexInput)
    End If
    
    Set sourceSheet = sourceWorkbook.Worksheets(sourceSheetName)
    If sourceSheet.Columns.Count < filterIndexNum Then
        MsgBox "数据源工作簿中筛选列的顺序不能大于数据源工作簿的列数"
        Exit Sub
    End If
     
    saveFolder = txt_saveFolder.Text
    If saveFolder = "" Then
        MsgBox "请输入拆分后保存的文件夹路径"
        Exit Sub
    End If
    
    Dim fol
    fol = Dir(saveFolder, vbDirectory)
    If fol = "" Then
        MkDir saveFolder
    End If
 
    filePrefix = txt_filePrefix.Text
    If filePrefix = "" Then
        MsgBox "请输入拆分后保存保存的文件前缀"
        Exit Sub
    End If
 
    
    
    'End '退出应用
       
      
    Set filterSheet = sourceWorkbook.Worksheets(groupSheetName)
    lastRow = filterSheet.Cells(Rows.Count, "A").End(xlUp).Row


    For i = 2 To lastRow
        currentValue = filterSheet.Cells(i, "A").Value
        
        Set targetWorkbook = Workbooks.Add
        Set targetSheet = targetWorkbook.Worksheets(1)
        targetSheet.Name = currentValue
        
         
        sourceSheet.UsedRange.AutoFilter field:=filterIndexNum, Criteria1:=currentValue
         
        sourceSheet.UsedRange.Copy targetSheet.Cells(1, 1)
        
         
        If cb_add_sn.Value = True Then
        
            Dim sourceRange As Range
            Dim targetColumn As Range
            Dim j, rowCount
            
            targetSheet.Columns("A").Insert '新增列
            Set sourceRange = Range("B:B")
            Set targetColumn = Range("A:A")
            sourceRange.Copy '复制第二列
            targetColumn.PasteSpecial xlPasteAll '粘贴到第一列，确保格式
            
            rowCount = targetSheet.Cells(Rows.Count, "A").End(xlUp).Row
            
            targetSheet.Range("A1").Value = "序号"
            For j = 2 To rowCount
                targetSheet.Range("A" & j).Value = j - 1
                targetSheet.Range("A" & j).HorizontalAlignment = xlCenter
                targetSheet.Range("A" & j).VerticalAlignment = xlCenter
            Next j
            
            
            'Do While targetSheet.Range()
        End If
        
        For Each columnTemp In targetSheet.Columns
            columnTemp.AutoFit
        Next
         
        targetWorkbookName = filePrefix & currentValue & ".xlsx"
        targetWorkbook.SaveAs Filename:=(saveFolder & targetWorkbookName)
        targetWorkbook.Close SaveChanges:=True
        Set targetWorkbook = Nothing
    Next i
    
    sourceSheet.UsedRange.AutoFilter
    sourceWorkbook.Close SaveChanges:=False
    Set sourceWorkbook = Nothing
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "拆分完成"
    
'ErrorHandler:

'    MsgBox "发生错误：" & vbCrLf & Err.Description
    
End Sub

Private Sub comBtn_Click()

     SplitExcelByMonth
     
End Sub