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

我刚刚开始学习VBA，而且我还没有使用代码。

任何人都可以帮助我如何将Excel文件分成几个工作簿基于行数？ 我有大约14K的Excel文件，我需要合并成less于10个工作簿。

在这个合并过程中，我想设置一个条件，其中1个工作簿最多只有80k行，下一个数据将被复制到一个新的工作簿（Book2）中。

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

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

既然你熟悉VBA，我只会给你一些伪代码。

以下是我该怎么做：

循环遍历每个工作簿，在嵌套循环中迭代直到工作簿的最后一行，复制的每一行上，我会增加一些Long值，当它达到80k时，然后closures当前工作簿，我们复制到另一个，然后创build另一个零我们的柜台：

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

此外，您可以使用文件对话框，而不是在InputBox中inputpath，请参阅： https : //msdn.microsoft.com/en-us/vba/excel-vba/articles/application-filedialog-property-excel

Answer 2

用以下replace复制/粘贴部分

 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