Splitting Files - Performance and Limitations

froobbie

New Member
Joined
Apr 9, 2016
Messages
4
Hi Folks,

I have created a macro splitting a block of data into many excels. It works for active sheet and as a criteria it uses a selected cell.
Macro itself works fine, however I am encountering some problems with performance and object methods. The error occurs every time I reach ~105 splitted files. That means I cannot split a file in one go into more than 105 files.
Could you please tell me what is going on and how I can prevent this from happening in the future?
The code is attached below. Macro itself is made in an user form

Code:
Private Sub ButtonPath_Click()

Set Fldr = Application.FileDialog(msoFileDialogFolderPicker)
With Fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strpath
    If .Show <> -1 Then GoTo NextCode
    Sitem = .SelectedItems(1)
End With

LBLPath = Sitem
LBLSheet = ActiveSheet.Name
LBLCriteria = ActiveCell.Value

NextCode:
GetFolder = Sitem
Set Fldr = Nothing

End Sub

Private Sub Cancel_Click()

Unload Me

End Sub


Private Sub OPTNo_Click()
Mirror = 1
End Sub

Private Sub OPTYes_Click()
Mirror = 2
End Sub

Private Sub Start_Click()

Application.ScreenUpdating = False

SplitSheet = ActiveWorkbook.ActiveSheet.Name
Set wb = ActiveWorkbook

Checker = 0

For Each Sheet In ActiveWorkbook.Worksheets

    If Sheet.Name = "Control" Then

    Checker = Checker + 1

    End If

Next

OrgFile = ActiveWorkbook.Name

If Checker = 0 Then

    ActiveWorkbook.Worksheets.Add after:=Sheets(Sheets.Count)
    ActiveWorkbook.Sheets(Sheets.Count).Name = "Control"
    
End If

Sheets("Control").Activate

    Sheets("Control").Cells.ClearContents
    Sheets("Control").Cells(1, 1).Value = "Name & Last Name"
    Sheets("Control").Cells(1, 2).Value = "E-mail Address"
    Sheets("Control").Cells(1, 3).Value = "Attachment Name"
    Sheets("Control").Cells(1, 4).Value = "Status of sending"
    Sheets("Control").Range(Cells(1, 1), Cells(1, 4)).Interior.ColorIndex = 33
    Sheets("Control").Range(Cells(1, 1), Cells(1, 4)).ColumnWidth = 30

ActiveWorkbook.Sheets(SplitSheet).Activate

actRow = 2
Col = ActiveCell.Column
Srow = ActiveCell.Row + 1

If ActiveWorkbook.Sheets(SplitSheet).AutoFilterMode Then
   On Error Resume Next
   ActiveWorkbook.Sheets(SplitSheet).ShowAllData
   On Error GoTo 0
End If

    
    On Error Resume Next
    l = ActiveWorkbook.Sheets(SplitSheet).Range(Cells(Srow, Col), Cells(1048576, Col).End(xlUp)).SpecialCells(xlCellTypeBlanks).Count
    On Error GoTo Handler
    
    If l <> 0 Then
    
    ActiveWorkbook.Sheets(SplitSheet).Range(Cells(Srow, Col), Cells(1048576, Col).End(xlUp)).SpecialCells(xlCellTypeBlanks).Select
    
    With Selection
    
        .Value = "Blank In Range"
    
    End With
    
    End If
    
    On Error GoTo Handler

    ActiveWorkbook.Sheets(SplitSheet).Range(Cells(Srow, Col), Cells(1048576, Col).End(xlUp)).Copy
       
    Sheets("Control").Activate
    
    Sheets("Control").Cells(2, 1).PasteSpecial xlPasteValues, skipblanks:=True, Transpose:=False
    
    Sheets("Control").Range(Cells(1, 1), Cells(1048576, 1).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
    
    ActiveWorkbook.SaveAs Filename:=Sitem & "\" & OrgFile, FileFormat:=xlOpenXMLWorkbook
    
    
    Do While ActiveWorkbook.Sheets("Control").Cells(actRow, 1) <> 0
      
    Crit = Sheets("Control").Cells(actRow, 1).Value
    
    ActiveWorkbook.SaveAs Filename:=Sitem & "\" & TXTPrefix & Crit & TXTSuffix, FileFormat:=xlOpenXMLWorkbook
    
    ActiveWorkbook.Sheets(SplitSheet).Activate
    
    With ActiveSheet
    
    .Cells(Srow - 1, 1).EntireRow.AutoFilter
    .Cells(Srow - 1, 1).EntireRow.AutoFilter Field:=Col, Criteria1:="<>" & Crit
    
    End With
    
    ActiveSheet.Range(Cells(Srow, Col), Cells(1048576, Col).End(xlUp)).EntireRow.Delete
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo Handler
        
    Application.DisplayAlerts = False
        
    If Mirror = 2 Then
    
    ActiveWorkbook.Sheets(Sheets.Count).Delete
    ActiveSheet.Copy after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "MirrorSheetTrack"
    ActiveWorkbook.Sheets(SplitSheet).Activate
    ActiveSheet.Range(Cells(Srow, 1), Cells(1048576, 700)).Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=A" & Srow & "<>" & "'MirrorSheetTrack'" & "!A" & Srow
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
    End With
    With Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(0)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior.Gradient.ColorStops.Add(1)
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    
    ActiveSheet.Cells(1, 1).Select
    Application.Goto Reference:=ActiveSheet.Range("A1"), Scroll:=True
    ActiveWorkbook.Sheets("MirrorSheetTrack").Visible = xlVeryHidden
    ActiveSheet.Protect Password:=TXTPassword, DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True
    ActiveWorkbook.Protect Password:=TXTPassword, structure:=True
    ActiveWorkbook.Save
    Set wb = ActiveWorkbook
    Workbooks.Open Filename:=Sitem & "\" & OrgFile, UpdateLinks:=False
    ActiveWorkbook.Sheets("Control").Cells(actRow, 3) = wb.Name
    ActiveWorkbook.Save
    wb.Close
    Application.DisplayAlerts = True
    Sitem = ActiveWorkbook.Path
    OrgFile = ActiveWorkbook.Name
    SplitSheet = LBLSheet
    actRow = actRow + 1
    
    Else
    
    ActiveWorkbook.Sheets(Sheets.Count).Delete
    Application.Goto Reference:=ActiveSheet.Range("A1"), Scroll:=True
    ActiveSheet.Protect Password:=TXTPassword, DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True
    ActiveWorkbook.Protect Password:=TXTPassword, structure:=True
    ActiveWorkbook.Save
    Set wb = ActiveWorkbook
    Workbooks.Open Filename:=Sitem & "\" & OrgFile, UpdateLinks:=False
    ActiveWorkbook.Sheets("Control").Cells(actRow, 3) = wb.Name
    ActiveWorkbook.Save
    wb.Close
    Application.DisplayAlerts = True
    Sitem = ActiveWorkbook.Path
    OrgFile = ActiveWorkbook.Name
    SplitSheet = LBLSheet
    actRow = actRow + 1
    
    End If
    
    Loop
    
    MsgBox "Task Compled!" & vbCrLf & actRow - 2 & " files were created", 64, "Operation Completed"
    
Exit Sub

Handler:

MsgBox "Error number: " & Err & " Occured" & vbCrLf & Error(Err), 16, "Error"

End Sub

Private Sub TXTPrefix_Change()

LBLFileName = TXTPrefix & "File Name" & TXTSuffix

End Sub

Private Sub TXTSuffix_Change()

LBLFileName = TXTPrefix & "File Name" & TXTSuffix

End Sub
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

baitmaster

Well-known Member
Joined
Mar 12, 2009
Messages
2,039
Why are you doing this?

If I was trying to pass data to many workbooks I probably wouldn't start cutting up my existing workbook, but instead get the data (perhaps in an array for improved speed), and loop through it a block at a time as follows:
- create a brand new file
- pass the current data block to worksheet 1
- save file
- close the file and remove it from memory
- move to next block

I suspect this may be simpler for the machine to process, and less likely to hang up. I can't guarantee it though, and I don't know why yours is getting confused after specifically 105 files
 

froobbie

New Member
Joined
Apr 9, 2016
Messages
4
Hi,

Thanks for your reply.

I did not manage to solve the problem, but I implemented the option to continue splitting from the point it stopped.
I will try to figure out what happens and if I have an answer, I will update the thread.
 

Watch MrExcel Video

Forum statistics

Threads
1,133,531
Messages
5,659,360
Members
418,499
Latest member
mbcmel

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top