I am trying to split a file with 120 records into files of at-most 50 records each. So expectation is it should genarate 2 files with 50 records and 1 file wit 20 but what I am getting is 3 files of 51 records with 1 empty file in the end for first 2 and 31 empty lines in 3rd file.
Sub SplitAndSaveFile()
Dim myRow As Long, myBook As Workbook, splitCount As Integer, thisWBName As String, splitCountStr As String, spaceRange As Range
lastRow = ThisWorkbook.Sheets("Data").Cells(rows.Count, 1).End(xlUp).Row
splitCount = 1
splitCountStr = CStr(splitCount)
thisWBName = Replace(ThisWorkbook.Name, ".xlsm", "") "_Part"
For myRow = 4 To lastRow Step 50
Set myBook = Workbooks.Add
ThisWorkbook.Sheets("Data").rows(myRow & ":" & myRow 49).EntireRow.Copy myBook.Sheets("Sheet1").Range("A1")
myBook.SaveAs (ThisWorkbook.Path "\" thisWBName splitCountStr ".txt"), FileFormat:=xlText
myBook.Close
splitCount = splitCount 1
splitCountStr = CStr(splitCount)
Next myRow
MsgBox ("File(s) generated.")
End Sub
CodePudding user response：
Export Data by Number of Rows
A Partial Quick Fix
- Your code seemed to work fine on my testing data, so the only thing I could think of, considering your description of the issue, was that in column
Athere are formulas evaluating to an empty string at the bottom, which you don't want to include. To fix this, you could use theFindmethod:
Dim LastRow As Long: LastRow = ThisWorkbook.Worksheets("Data") _
.Columns("A").Find("*", , xlValues, , , xlPrevious)
- Unfortunately, you also didn't consider the case when there will be fewer than 50 records to be copied to the last workbook. See how it is handled in the 'In-Depth' solution.
In Depth
- This will export the records in a worksheet to new workbooks, saved as text, containing maximally 50 rows.
Option Explicit
Sub SplitAndSaveFile()
Const ProcName As String = "SplitAndSaveFile"
Dim dwbCount As Long ' Generated Workbooks Count
On Error GoTo ClearError
' Source
Const swsName As String = "Data"
Const sCol As String = "A"
Const sfRow As Long = 4
' Destination
Const dfCellAddress As String = "A1" ' needs to be 'A' since entire rows.
Const dMaxRows As Long = 50
Const dNameSuffix As String = "_Part"
' In the loop, this will be replaced by a number ('dwbCount').
Const dIdPlaceHolder As String = "?" ' the '?' is illegal for file names
' The following two lines are dependent on each other.
Const dFileExtension As String = ".txt"
Dim dFileFormat As XlFileFormat: dFileFormat = xlText
' Create a reference to the source first cell ('sfCell').
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets(swsName)
Dim sfCell As Range: Set sfCell = sws.Cells(sfRow, sCol)
' Calculate the number of records (rows) ('drCount').
' This will find the last non-blank cell i.e. cells containing
' formulas evaluating to an empty string are ignored.
' Make sure that the worksheet is not filtered and there are no hidden
' cells.
Dim slCell As Range
Set slCell = sfCell.Resize(sws.Rows.Count - sfRow 1) _
.Find("*", , xlValues, , , xlPrevious)
If slCell Is Nothing Then Exit Sub ' no data
Dim slRow As Long: slRow = slCell.Row
' This is the preferred way, but besides a few pros, it behaves like 'End'
' i.e. it will find the last non-empty cell. A cell is not empty
' if it contains a formula evaluating to an empty string ('""'):
' it is blank.
'Dim slCell As Range
'Set slCell = sfCell.Resize(sws.Rows.Count - sfRow 1) _
.Find("*", , xlFormulas, , , xlPrevious)
'If slCell Is Nothing Then Exit Sub ' no data
'Dim slRow As Long: slRow = slCell.Row
' The classic last row using 'End' will find the last non-empty cell.
'Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sCol).End(xlUp).Row
Dim drCount As Long: drCount = slRow - sfRow 1
If drCount < 1 Then Exit Sub ' no data (highly unlikely but...)
' Determine the generic file path (dwbGenericFilePath)
Dim swbBaseName As String: swbBaseName = swb.Name
Dim DotPosition As String: DotPosition = InStrRev(swb.Name, ".")
If DotPosition > 0 Then swbBaseName = Left(swbBaseName, DotPosition - 1)
Dim dwbExtension As String: dwbExtension = dFileExtension
If Left(dwbExtension, 1) <> "." Then dwbExtension = "." & dwbExtension
Dim dwbGenericFilePath As String
dwbGenericFilePath = swb.Path & Application.PathSeparator & swbBaseName _
& dNameSuffix & dIdPlaceHolder & dwbExtension
Application.ScreenUpdating = False
' Additional variables used in the loop.
Dim srg As Range
Dim dwb As Workbook
Dim dws As Worksheet
Dim dfCell As Range
Dim dFilePath As String
Do Until drCount = 0
' Create a reference to the current source range.
If drCount > dMaxRows Then ' all workbooks but the last
Set srg = sfCell.Resize(dMaxRows).EntireRow
Set sfCell = sfCell.Offset(dMaxRows)
drCount = drCount - dMaxRows
Else ' the last workbook
Set srg = sfCell.Resize(drCount).EntireRow
drCount = 0
End If
' Copy the current source range to the current destination range.
dwbCount = dwbCount 1 ' count the number of generated workbooks
Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet only
Set dws = dwb.Worksheets(1)
Set dfCell = dws.Range(dfCellAddress)
srg.Copy dfCell
' Save and close the current destination workbook.
dFilePath = Replace(dwbGenericFilePath, dIdPlaceHolder, CStr(dwbCount))
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath, dFileFormat
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Loop
ProcExit:
Application.ScreenUpdating = True
Select Case dwbCount
Case 0
MsgBox "No files generated.", vbCritical, ProcName
Case 1
MsgBox "One file generated.", vbInformation, ProcName
Case Else
MsgBox dwbCount & " files generated.", vbInformation, ProcName
End Select
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub