Prevent macro vba from copying and pasting empty rows when splitting files where split range exceeds-CodePudding

I found a code here that works perfectly for what i want to do which is to split a large excel file into smaller csv files. However, upon checking the output csv, the output copy and pastes empty rows when the number of rows left is less than the number in the loop as shown in the picture. Is there any way to prevent that from happening inside the loop? Thanks in advance.

Dim rLastCell As Range
Dim rCells As Range
Dim strName As String
Dim lLoop As Long, lCopy As Long
Dim wbNew As Workbook

With Sheets("Sheet1")
Set rLastCell = .UsedRange.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious)

For lLoop = 2 To rLastCell.Row Step 3000
    lCopy = lCopy   1
    Set wbNew = Workbooks.Add
    .Rows(1).EntireRow.Copy _
    Destination:=wbNew.Sheets(1).Range("A1")
    .Range(.Cells(lLoop, 1), .Cells(lLoop   3000, .Columns.Count)).EntireRow.Copy _
    Destination:=wbNew.Sheets(1).Range("A2")
    wbNew.SaveAs Filename:="C:\Users\Documents" & 
    "product_catalog_" & fileDate & "_" & Format(lLoop   2999, "0000") & ".csv", 
    FileFormat:=xlCSV, 
    Local:=True
    wbNew.Close SaveChanges:=True
    Next lLoop
    End With

CodePudding user response：

I introduced a variable called rowsToDo in order to do this, with the min of 3000 or the number of rows left:

Sub testCSV()
    Dim rLastCell As Range
    Dim rCells As Range
    Dim strName As String
    Dim lLoop As Long, lCopy As Long
    Dim wbNew As Workbook
    
    With Sheets("CSV Table")
        Set rLastCell = .UsedRange.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious)
    
        For lLoop = 2 To rLastCell.Row Step 3000
            rowsToDo = rLastCell.Row - lLoop
            If rowsToDo > 3000 Then rowsToDo = 3000
            lCopy = lCopy   1
            Set wbNew = Workbooks.Add
            .Rows(1).EntireRow.Copy Destination:=wbNew.Sheets(1).Range("A1")
            .Range(.Cells(lLoop, 1), .Cells(lLoop   rowsToDo, .Columns.Count)).EntireRow.Copy Destination:=wbNew.Sheets(1).Range("A2")
            wbNew.SaveAs Filename:="C:\Users\Documents" & "product_catalog_" & fileDate & "_" & Format(lLoop   2999, "0000") & ".csv", FileFormat:=xlCSV, Local:=True
            wbNew.Close SaveChanges:=True
        Next lLoop
    End With
End Sub

Notice that I then use this in the copy and destination statement for the number of rows to copy through.

Worked on my very quick mock up of the issue, though honestly I couldn't replicate the problem I'm fairly sure this should solve it

CodePudding user response：

Please, test the next way. It is faster in terms of copying the necessary range (not using clipboard) and calculate the exact number of remained not empty rows for the last loop.

Do not forget to change the line fileDate = "Test" with your correct/necessary definition (missing from the above code...) :

Sub CreateCSVFiles()
 Dim rLastCell As Range, rCells As Range, strName As String
 Dim lLoop As Long, lCopy As Long, wbNew As Workbook
 Dim lngStep As Double, iLast As Long, lastSliceRows As Long, fileDate As String

 fileDate = "Test" 'place here your real value (missing from the shown code...)
 With Sheets("Sheet1")
    Set rLastCell = .UsedRange.Find(What:="*", After:=.Range("A1"), SearchDirection:=xlPrevious)
    lngStep = 5
    For lLoop = 2 To rLastCell.row Step lngStep
        If (rLastCell.row - 1) / lngStep Mod 2 <> 0 Then
            iLast = Int((rLastCell.row - 1) / lngStep)   1
            lastSliceRows = (rLastCell.row - 1) - Int(rLastCell.row / lngStep) * lngStep:  'Stop
        Else
            iLast = Int(rLastCell.row / lngStep): lastSliceRows = lngStep
        End If
        lCopy = lCopy   1
        Set wbNew = Workbooks.Add

        'much faster way to copy the necessary values, without using clipboard:
        wbNew.Sheets(1).Range("A1").EntireRow.value = .rows(1).EntireRow.value
        wbNew.Sheets(1).Range("A2").Resize(IIf(lLoop = iLast, lastSliceRows, lngStep), Columns.count).value = _
                 .Range(.cells(lLoop, 1), .cells(lLoop   IIf(lLoop = iLast, lastSliceRows, lngStep), .Columns.count)).EntireRow.value
    
        wbNew.saveas fileName:="C:\Users\Documents" & _
              "product_catalog_" & fileDate & "_" & Format(lLoop   2999, "0000") & ".csv", _
                FileFormat:=xlCSV, Local:=True
        wbNew.Close SaveChanges:=False ' True is useless in this content, it only makes the code slower saving for the second time.
      Next lLoop
 End With
End Sub

Please, send some feedback after testing it.