Hi All

I've been using the following code to generate all the possible 649 combinations. This code will create a sheet containing the combinations, the combinations will be 1,000,000 lines long on Part001, Part002, etc, up to Part014. When I run this after the first couple of parts my computer really starts to slow down until it eventually crawls to the end and all the combinations have been generated.

Is there a way to modify the code that after each part is generated the file is saved and that part is closed? And then the next part can be generated saved and closed and so on until all combinations have been generated, thus helping pervent my computer from slowing down to the speed of a snail? Thanks

Option Explicit
 
Public Sub Generate6ex49()
 
Const MainSheet As String = "Sheet1"
Const SheetPrefix As String = "Part"
Const SplitPoint As Long = 1000000
Const HighBall As Integer = 49
 
Dim iPtr As Integer
Dim sFileName As String
Dim SheetNumber As Integer
Dim iRow As Long
Dim iRec As Long
Dim iLastRow As Long
Dim ws As Worksheet
Dim sMessage As String
Dim sTime As Date
 
Dim p1 As Integer
Dim p2 As Integer
Dim p3 As Integer
Dim p4 As Integer
Dim p5 As Integer
Dim p6 As Integer
 
For Each ws In ThisWorkbook.Worksheets
If Left(ws.Name, Len(SheetPrefix)) = SheetPrefix Then
  Application.DisplayAlerts = False
  On Error Resume Next
  ws.Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
End If
Next ws
 
Sheets(MainSheet).Columns("A:B").ClearContents
 
sMessage = vbCrLf & "Workbook reset. Proceed to create combination records?" _
       & Space(10) & vbCrLf & vbCrLf _
       & "Warning: this will take several minutes!"
If MsgBox(sMessage, vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
 
Sheets(MainSheet).Range("A1:B1").Font.Bold = True
Sheets(MainSheet).Range("A1") = "Worksheet"
Sheets(MainSheet).Range("B1") = "Records"
 
sTime = Now()
SheetNumber = 0
iRow = SplitPoint
iRec = 0
 
For p1 = 1 To HighBall - 5
For p2 = p1 + 1 To HighBall - 4
  For p3 = p2 + 1 To HighBall - 3
    For p4 = p3 + 1 To HighBall - 2
      For p5 = p4 + 1 To HighBall - 1
        For p6 = p5 + 1 To HighBall
          iRec = iRec + 1
          iRow = iRow + 1
          If iRow > SplitPoint Then
            If SheetNumber > 0 Then
              iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
              Sheets(MainSheet).Cells(iLastRow, 2) = iRow - 1
            End If
            SheetNumber = SheetNumber + 1
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = SheetPrefix & Right("00" & CStr(SheetNumber), 3)
            Sheets(MainSheet).Activate
            iLastRow = Sheets(MainSheet).Cells(Rows.Count, 1).End(xlUp).Row
            Set ws = Sheets(SheetPrefix & Right("00" & CStr(SheetNumber), 3))
            Sheets(MainSheet).Cells(iLastRow + 1, 1) = ws.Name
            iRow = 1
          End If
          ws.Cells(iRow, 1) = p1
          ws.Cells(iRow, 2) = p2
          ws.Cells(iRow, 3) = p3
          ws.Cells(iRow, 4) = p4
          ws.Cells(iRow, 5) = p5
          ws.Cells(iRow, 6) = p6
          DoEvents
        Next p6
      Next p5
    Next p4
  Next p3
Next p2
Next p1
 
Sheets(MainSheet).Cells(iLastRow + 1, 2) = iRow
Sheets(MainSheet).Cells(iLastRow + 2, 1) = "Total"
Sheets(MainSheet).Cells(iLastRow + 2, 2) = iRec
Sheets(MainSheet).Columns("A:B").EntireColumn.AutoFit
Sheets(MainSheet).Range("A1").Select
 
MsgBox vbCrLf & Format(iRec, "#,###") & " records created" & Space(10) & vbCrLf & vbCrLf _
   & CStr(SheetNumber) & " worksheets created" & vbCrLf & vbCrLf _
   & "Run time: " & Format(Now() - sTime, "hh:nn:ss"), vbOKOnly + vbInformation
 
End Sub