如何将Excel分割成几个行数固定的工作簿

I just started to learn VBA and I'm still not getting used with the codes yet.

我刚开始学习VBA，我还没有习惯使用这些代码。

Can anyone help me on how to split up Excel files into several workbooks based on number of rows? I have roughly 14k of Excel files that I need to consolidate into less than 10 workbooks.

谁能帮我把Excel文件根据行数分成几个工作簿吗?我有大约14k个Excel文件需要合并到不到10个工作簿中。

During this consolidation, I want to set a condition where 1 workbook will only have maximum of 80k rows and the next data will be copied into a new workbook (Book2).

在此合并期间，我想设置一个条件，其中一个工作簿最多只有80k行，下一个数据将被复制到一个新的工作簿(Book2)。

Following is the consolidation code that I have but where can I insert the row condition?

下面是我的合并代码，但是我可以在哪里插入行条件呢?

Sub MergeFiles()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer

CurrFilename = ThisWorkbook.FullName

ary = Split(CurrFilename, "\")
bry = Split(ary(UBound(ary)), ".")
ary(UBound(ary)) = ""
CurrFilename2 = bry(0)

Selection.SpecialCells(xlCellTypeLastCell).Select
CurrTheLastRow = ActiveCell.Row
Range("A1:A" & CurrTheLastRow) = CurrFilename2

RowofCopySheet = 2

ThisWB = ActiveWorkbook.Name

path = InputBox("Enter file path")

Application.EnableEvents = False
Application.ScreenUpdating = False

Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
    If Not Filename = ThisWB Then
        Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)

        ary = Split(Filename, "\")
        bry = Split(ary(UBound(ary)), ".")
        ary(UBound(ary)) = ""
        Filename2 = bry(0)


        Selection.SpecialCells(xlCellTypeLastCell).Select
        TheLastRow = ActiveCell.Row
        Range("A1:A" & TheLastRow) = Filename2

        Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
        Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
        CopyRng.Copy Dest
        Wkb.Close False
    End If

    Filename = Dir()
Loop

Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Done!"
End Sub

2 个解决方案

#1

Since you are familiar with VBA, I will just give you some pseudo code.

因为您熟悉VBA，所以我只提供一些伪代码。

Here's how I'd do it:

下面是我的做法:

Loop through every workbook, in nested loop I would iterate until last row of a workbook, on every row copied I would increment some Long value, when it reaches 80k, then I would close current workbook, which we copy to, create another one and zero our counter:

循环遍历每个工作簿，在嵌套循环中，我将迭代到工作簿的最后一行，在复制的每一行上，我将增加一些长值，当它达到80k时，我将关闭当前的工作簿，我们将它复制到，创建另一行，并将计数器归零:

If someLongValue = 80000 Then
    'close workbook
    'create another one
    someLongValue = 0
End If

Also, you can use file dialogs, instead of entering path in the InputBox, see: https://msdn.microsoft.com/en-us/vba/excel-vba/articles/application-filedialog-property-excel

另外，可以使用文件对话框，而不是在InputBox中输入路径，参见:https://msdn.microsoft.com/en-us/vba/excel- vba/articles/applicfiledialog -property-excel

#2

Replace copy/paste section with following

将复制/粘贴部分替换为以下内容

Dim WRCount  As Double
Dim WCCount  As Double
Dim MAXCount  As Double
Dim StartRow As Integer
Dim LoopCount As Integer
Dim CellsToCopy As Double

LoopCount = 1
MAXCount = 80000
StartRow = 1
WRCount = ActiveSheet.UsedRange.Rows.Count
WCCount = ActiveSheet.UsedRange.Columns.Count

Do While StartRow < WRCount

    CellsToCopy = StartRow + MAXCount

    If CellsToCopy > WRCount Then
        CellsToCopy = WRCount
    End If
    Set CopyRng = Wkb.Sheets(1).Range(Cells(StartRow, 1), Cells(CellsToCopy, WCCount))
    Set shtDest = ActiveWorkbook.Sheets(LoopCount)
    Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    CopyRng.Copy Dest
    StartRow = StartRow + MAXCount
    LoopCount = LoopCount + 1
Loop

#1