How to split Excel into several workbook with fixed number of rows count

Viewed 156

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

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.

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).

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 Answers
Related