按可变行数拆分Excel电子表格(例如:约5000行加上最大1000行)

Question

如何将一个excel文件拆分为多个文件，事先不知道要在哪里拆分的确切行数，但只知道在哪里拆分一个粗略的数字

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

行#：列A内容：

行1:namedBB

第2行：namedBB

第251行：namedBB

第252行：命名的CC

第4999行：命名的DD

row5000:命名的DD

第5365行：命名的DD

第5366行：命名KEI

等等。

在本例中，我希望将文件拆分为大约每5000行。但事实上，第一个分割应该正好在5366上（所以第一个xslx文件的内容从row1到row5365，第二个xslx将从row5366到？…）

这是我用来拆分固定行数的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

我会简单地将数据集拆分为工作表，100000并不算多。

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