按可变行数拆分 Excel 电子表格（例如：大约 5,000 行加上最多 1,000 行）

Question

如何将一个 excel 文件拆分成几个文件，事先不知道要告诉 Excel 拆分的确切行数，但只知道粗略的行数拆分 ?

示例： 总共 100,000 行。在 A 列中，我有许多行以相同的单元格内容开头。我知道我最多有 1,000 行具有相同的 A 列内容。

行#：A列内容：

第 1 行：namedBB

第 2 行：namedBB

...

行 251:namedBB

行 252:namedCC

...

第 4,999 行：namedDD

第 5,000 行：namedDD

...

第 5,365 行：namedDD

row5,366:namedKEI

...等...

在此示例中，我想将文件拆分为大约每 5,000 行。但实际上第一次拆分应该恰好在 5,366 上（因此第一个 xslx 文件的内容将从 row1 到 row5,365，第二个 xslx 文件的内容将从 row5,366 到？...）。

这是我用来拆分固定行数的 VBA 代码。

Sub Splitter_fixed_number_of_rows()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim lTop As Long, lBottom, lCopy As Long
Dim LastRow As Long, LastCol As Long
Dim wbNew As Workbook, sPath As String

With ThisWorkbook.Sheets("recap")  ' sheetname to adapt
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lTop = 2
Do

lBottom = lTop + 5000   ' fixed number of row where to split //to adapt
If lBottom > LastRow Then lBottom = LastRow
lCopy = lCopy + 1

Set wbNew = Workbooks.Add
.Range(.Cells(1, 1), .Cells(1, LastCol)).Copy
wbNew.Sheets(1).Range("A1").PasteSpecial
.Range(.Cells(lTop, 1), .Cells(lBottom, LastCol)).Copy
wbNew.Sheets(1).Range("A2").PasteSpecial

wbNew.SaveAs Filename:="TEST_" & Application.ActiveWorkbook.FullName & lCopy, FileFormat:=xlOpenXMLWorkbook ' split into .xslx files
wbNew.Close

lTop = lBottom + 1
Loop While lTop <= LastRow
End With

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

谢谢 ;)

Answer 1

我想你可以添加下面的代码行来动态搜索第 5xxx 行

在下面添加以下几行lCopy = lCopy + 1

For lBottom = lBottom To lBottom + 999
    If Range("A" & lBottom) <> Range("A" & lBottom + 1) Then
        Exit For
    End If
Next lBottom

新修改代码

Sub Splitter_fixed_number_of_rows()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim lTop As Long, lBottom, lCopy As Long
Dim LastRow As Long, LastCol As Long
Dim wbNew As Workbook, sPath As String

With ThisWorkbook.Sheets("recap")  ' sheetname to adapt
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lTop = 2
Do

lBottom = lTop + 5000   ' fixed number of row where to split //to adapt
lCopy = lCopy + 1

For lBottom = lBottom To lBottom + 999
    If Range("A" & lBottom) <> Range("A" & lBottom + 1) Then
        Exit For
    End If
Next lBottom

If lBottom > LastRow Then lBottom = LastRow

Set wbNew = Workbooks.Add
.Range(.Cells(1, 1), .Cells(1, LastCol)).Copy
wbNew.Sheets(1).Range("A1").PasteSpecial
.Range(.Cells(lTop, 1), .Cells(lBottom, LastCol)).Copy
wbNew.Sheets(1).Range("A2").PasteSpecial

wbNew.SaveAs Filename:="TEST_" & Application.ActiveWorkbook.FullName & lCopy, FileFormat:=xlOpenXMLWorkbook ' split into .xslx files
wbNew.Close

lTop = lBottom + 1
Loop While lTop <= LastRow
End With

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Answer 2

Sub ertdfgcvb()
rcount = 0
nameseries = ""

For i = lTop + 1 To LastRow
cellname = Cells(i, 1)
If rcount > 5000 Then
    If cellname <> nameseries Then
        rcount = 0
        nameseries = cellname
        'generate new file, range that needs be copied is header and Range(Cells(i-rcount,LastColumn),Cells(i,LastColumn)
    End If
rcount = rcount + 1
End If

End Sub

我会简单地将数据集拆分为工作表，100,000 个不算多。

Answer 3

如果我正确理解你的问题：

Sub M_snb()
  On Error Resume Next

  Do
    With Columns(1).SpecialCells(2)
      If Err.Number <> 0 Then Exit Sub

      .Cells(1).Resize(Application.Match(.Cells(1).Value, .Offset(0), 1)).Cut
      Sheets.Add.Paste
    End With
  Loop
End Sub

按可变行数拆分 Excel 电子表格（例如：大约 5,000 行加上最多 1,000 行）

Split Excel spreadsheet by variable number of rows (eg: about 5,000 rows plus max 1,000)

excel

vba

split