How to split Excel into multiple workbooks with a fixed number of rows

Question

I just started learning VBA, and I'm still not used to codes.

Can someone help me split Excel files into multiple workbooks based on row count? I have approximately 14 thousand Excel files that I need to combine into less than 10 workbooks.

During this consolidation, I want to establish a condition where 1 workbook will contain a maximum of 80 thousand lines, and the following data will be copied to a new book (Book 2).

Below is the consolidation code that I have, but where can I insert a 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

Answer 1

Replace the copy / paste section with the 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

Answer 2

VBA, .

:

, , Long, 80k, , , :

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

, , InputBox, . https://msdn.microsoft.com/en-us/vba/excel-vba/articles/application-filedialog-property-excel