Question

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

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

row＃：A列内容：

ROW1：namedBB

ROW2：namedBB

...

row251：namedBB

row252：namedCC

...

row4,999：namedDD

row5,000：namedDD

...

row5,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行）

3 个答案: