vba - 按可变行数拆分 Excel 电子表格(例如 : about 5, 000 行加上最多 1,000 行)

Question

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

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

第 # 行:A 列内容:

行 1:namedBB

行 2:namedBB

...

行251:命名BB

row252:namedCC

...

第 4,999 行:namedDD

第 5,000 行:namedDD

...

第 5,365 行:namedDD

row5,366:namedKEI

...等...

在此示例中，我想将文件拆分为大约每 5,000 行。但实际上第一次拆分应该恰好在 5,366 上(因此第一个 xslx 文件的内容将从第 1 行到第 5,365 行，第二个 xslx 文件的内容将从第 5,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