Splitting Files - Performance and Limitations

[froobbie]

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

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

 

[baitmaster]

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]

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.