哪位大哥帮我看看excel怎么拆分每个文件都是1万个数据，每个文件第一行标题需要保留

动鸡不醇

哪位大哥帮我看看excel总表怎么自动拆分每个文件都是1万个数据，保存N个文件，每个文件第一行标题需要保留

因为还有上百万个文件需要拆分  非常感谢

沈默00

你得说明如何拆分吧，按什么条件拆分，，，最好模拟一下结果，，，
用VBA处理

动鸡不醇

沈默00 发表于 2024-6-1 16:59
你得说明如何拆分吧，按什么条件拆分，，，最好模拟一下结果，，，
用VBA处理

您好，就按照里面的数据   1-10000行保存为一个文件

沈默00

动鸡不醇 发表于 2024-6-1 17:17
您好，就按照里面的数据   1-10000行保存为一个文件

弄半天还以为是按三个空行分表，，，，三个空行还需要保留吗，还是也一起做删除处理了

动鸡不醇

沈默00 发表于 2024-6-1 17:28
弄半天还以为是按三个空行分表，，，，三个空行还需要保留吗，还是也一起做删除处理了

我这里有个代码，就是保存第一个文件的时候是空白的，后面的文件就不会，麻烦您帮我看看

Sub 宏1()
    hs = Worksheets("sheet3").UsedRange.Rows.Count
    wjs1 = (hs - 1) / 10000
    wjs2 = Int(wjs1)
    If wjs1 - wjs2 > 0 Then
        wjs0 = wjs2 + 1
    Else
        wjs0 = wjs2
    End If
    MsgBox ("请选择需要合并的excel所在文件夹")
    Set objFD = Application.FileDialog(msoFileDialogFolderPicker)
        With objFD
            If .Show = -1 Then
    '            如果单击了确定按钮，则将选取的路径保存在变量中
                spath = .SelectedItems(1)
            End If
        End With
    Debug.Print spath
    lujing1 = spath + "\第"
    Dim Wb As Excel.Workbook
    Dim Wk As Excel.Workbook
    Set Wk = ThisWorkbook
    For i = 1 To wjs0
      Workbooks.Add
            ActiveWorkbook.SaveAs Filename:=lujing1 & i & "个文件.xlsx", FileFormat:= _
             xlOpenXMLWorkbook, CreateBackup:=False
    Set Wb = Application.Workbooks.Open(lujing1 & i & "个文件.xlsx")
    Wk.Activate
    Range("1:1").Select
    Selection.Copy
    Wb.Activate
    Worksheets("sheet1").Activate
    Worksheets("sheet1").Rows(1).Select
    ActiveSheet.Paste
    Wk.Activate
    If i = 1 Then
      j = 2
    ElseIf i = wjs0 Then
      j = (i - 1) * 10000 + 2
      Range(j & ":" & hs).Select
    Else
     j = (i - 1) * 10000 + 2
     Range(j & ":" & (i * 10000 + 1)).Select
    End If
    Selection.Copy
    Wb.Activate
    Worksheets("sheet1").Activate
    Worksheets("sheet1").Rows(2).Select
    ActiveSheet.Paste
    Range("B1:B501").Select
    Selection.NumberFormatLocal = "G/通用格式"
    ActiveWorkbook.Close savechanges:=True
    Wk.Activate
    Next i
      
   
  
End Sub

沈默00

你没回答我的问题，这是没有删除空白行的代码，，如果要删，你自己加吧

沈默00

你先试试，数据多可能会慢点，真的太慢就换成数组写

3190496160

Sub 按行拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long
Dim br(), cr()
Dim rn As Range
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:d" & r)
    Set rn = .Rows(1)
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 1 To UBound(ar)
        If ar(i, 1) <> "" Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                br(n, j) = ar(i, j)
            Next j
        End If
    Next i
End With
lj = ThisWorkbook.Path & "\拆分文件\"
Application.SheetsInNewWorkbook = 1
For i = 2 To n Step 10000
    m = 0: k = k + 1
    ReDim cr(1 To UBound(ar), 1 To UBound(ar, 2))
    For s = i To i + 9999
        If s <= n Then
            m = m + 1
            For j = 1 To UBound(br, 2)
                cr(m, j) = br(s, j)
            Next j
        End If
    Next s
    Set wb = Workbooks.Add
    With wb.Worksheets(1)
        .Name = k
        .Columns(3).NumberFormatLocal = "@"
        rn.Copy .[a1]
        .[a2].Resize(m, UBound(cr, 2)) = cr
        .Columns("a:c").AutoFit
    End With
    wb.SaveAs Filename:=lj & k & ".xlsx"
    wb.Close
Next i
Application.ScreenUpdating = True
MsgBox "共拆分了" & k & "个文件！"
End Sub

3190496160

格式.rar (538.71 KB, 下载次数: 2)

2024-6-2 10:45 上传

点击文件名下载附件

沈默00

还是用数组快些，，，