将excel拆分成多个文件

 

Sub copybat()
    Dim i, j, k, m, r As Integer
    Dim n, total_data As Long
    Dim path As String
    Dim title_area, data_column, data_areas As Range
   
    Set title_area = Application.InputBox(prompt:="请用鼠标选择表头及表标题所在区域", title:="选择", Type:=8) '选取表头区域
    Set data_column = Application.InputBox(prompt:="请鼠标选择需要拆分数据的开始行区域", title:="选择", Type:=8) '选取拆分起始处
    m = data_column.Row      '获取分割开始行所在区域行号
    r = data_column.Column   '获取分割开始行所在区域列号
    j = data_column.Columns.Count   '获取分割开始行区域列数
    i = Application.InputBox(prompt:="请输入每次分割数据条目数", title:="选择")
  
   '获取需要分割的数据总条数。这里，可以用两种办法获取到数据区域的尾部行号
      '第一种，使用传统的：End(xlDown).Row，优点是速度快，缺点是有空白行时会出错
      '第二种，使用查找方式find，优点是基本不会出错，缺点是条数较多时候可能会慢一点
   'total_data = Cells(data_column(1, 1)).End(xlDown).Row - m + 1 
    total_data= Cells.Find("*", LookIn:=xlFormulas, SearchDirection:=xlPrevious).Row- m + 1   
    If MsgBox("本次分割文件数据总数为:" & total_data & "条，将会被分割成" & WorksheetFunction.RoundUp(total_data / i, 0) & "个文件，" _
                & "点击“确定”开始分割，点击“取消”返回", vbOKCancel, "确认") = vbOK Then
        filename = Application.InputBox(prompt:="请输入分割后的文件主名，默认为“分割文件”", title:="选择", Default:="分割文件") 
        With Application.FileDialog(msoFileDialogFolderPicker)  '获取分割后的文件存储路径
            If .Show = False Then Exit Sub
                path = .SelectedItems(1)&"\"   '加入"\",否则，文件会被存储到选定路径的上一层
        End With
        Application.ScreenUpdating = False
        k = 0   '第几次分割输出，用于标识分割文件次数
        For n = m To total_data Step i   '从开始分割的行往下计数
            Set data_areas = Range(Cells(n, r), Cells(n + i - 1, j))   '设置每次循环体内的分割数据主体
            Application.Union(title_area, data_areas).Select           '把表头区域以及本次循环体内的数据区域进行合并
            Selection.Copy
            Workbooks.Add
            Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False      '特殊粘贴：包含源格式的粘贴，以便保持所有格式一致
           k = k + 1
           ActiveWorkbook.SaveAs filename:=path & filename & "_" & k & ".xlsx", FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False      '按照既有的文件名、路径、循环次数合并起来存储文件
            ActiveWindow.Close
        Next n
        MsgBox "文件分割完毕！", vbDefaultButton1, "提示"
    End If
    Application.ScreenUpdating = True
End Sub

转载https://zhuanlan.zhihu.com/p/81580481?from_voters_page=true