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

如何将excel文件拆分成几个不知道提前知道Excel分割行数的文件，但只知道一个粗略的数字在哪里拆分？

例如：总共100,000行。 在列A中，我有许多行由相同的单元格内容开始。 我知道我最多有1000行具有相同的列A内容。

行＃：列A内容 ：

ROW1：namedBB

2行：namedBB

…

row251：namedBB

row252：namedCC

…

row4,999：namedDD

row5,000：namedDD

…

row5,365：namedDD

row5,366：namedKEI

…等等…

在这个例子中，我想将文件分割成大约每行5000行。 但事实上，第一个分割应该是完全在5,366（所以第一个xslx文件将有从第一行到第五行，第365行的内容，第二个xslx文件将从第5366行到…）。

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

我认为你可以添加下面的代码行来dynamic地search第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 

我只是简单地把数据集分解成工作表，而十万不是那么多。

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