Macro has suddenly started to run slow and consumer all resources.

[taylorsm]

I can not think of anything I have changed in the code. The code splits a spread sheet up into 240 separate but similar sheets. It use to take less than 5 minutes, now i've let it run an hour and nothing, or the tabs will be there like it has done them, but I can't verify the status because I can't check for 240 tabs since the sheet is locked up with the macro running. Same laptop running windows 7 with 16gb of ram and a I7 processor. So the power is there. I close out of all programs other than excel too. It is even the same file that I did last that was successful.

Option Explicit

Sub EDNotepadSplit()
    Dim myAreas As Areas, I As Long, ii As Long, n As Long, rng As Range
    Application.ScreenUpdating = False
    Set myAreas = ActiveSheet.Columns(1).SpecialCells(2).Areas
    For I = 1 To myAreas.Count
        If myAreas(I)(1).Font.Bold Then
            Set rng = myAreas(I).Resize(myAreas(I).Count + 1)
            ii = 1
            Do While I + ii <= myAreas.Count
                If myAreas(I + ii)(1).Font.Bold Then Exit Do
                Set rng = Union(rng, myAreas(I + ii))
                ii = ii + 1
            Loop
            n = n + 1: If "Sheet" & n = myAreas.Parent.Parent.Name Then n = n + 1
            DeleteSheet "Sheet" & n
            myAreas.Parent.Parent.Copy after:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = "Sheet" & n: .Cells.ClearContents
                rng.EntireRow.Copy .Cells(1)
            End With
            I = I + ii - 1: Set rng = Nothing
        End If
    Next
    myAreas.Parent.Parent.Select
    Application.ScreenUpdating = True
End Sub

Private Sub DeleteSheet(ByVal wsName As String)
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets(wsName).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
End Sub

[EssoExplJoe]

I didn't test your code but I don't think its wise to reset the counter in a for/next loop from within the loop. check out your statement "I = I + ii - 1" You can easily get into an endless loop this way.

[taylorsm]

Thank you for the response. I guess I should have mentioned that I did not write the code and while I am learning and can fumble through some minor adjustments, the part you referenced is absolutely greek to me. Could you elaborate on what you mean?

[jindon]

Seems I wrote the code. (Althoug, I never use variable "I" for a counter, always "i")

Just try add one line

            With ActiveSheet
                .Name = "Sheet" & n: .Cells.ClearContents
                rng.EntireRow.Copy .Cells(1)
                Application.CutCopyMode = False
            End With

Otherwise, need to see your workbook.

[taylorsm]

Hey thanks, that did not seem to speed it up or from what I could tell, change anything. I've attached a short sample.

I start off with the "Packet" sheet and then run the macro, resulting in Sheet1-240. So if you want to walk through it just run my macro.

I wiped all the personal data and then duplicated them over and over and luckily pasted randomly 240 accounts. Ran the macro and it took less than a minute. So something about the content seems to affect it?

[EssoExplJoe]

I have found that formatting cell by cell takes a lot more time than just copying cell to cell. I see that in your code you read and re-format cells.

[jindon]

Once it create 240 sheets with format(it was the request from the original question), the size goes up to about 70MB from only 340KB.
Then whatever you want to do, it will be very slow.

This will create new workbook, so original workbook will never be getting bigger.

Sub test()
    Dim myAreas As Areas, i As Long, ii As Long, n As Long, rng As Range
    Application.ScreenUpdating = False
    With Workbooks.Add
        ThisWorkbook.Sheets("Packet Detail Report").Copy before:=.Sheets(1)
        Set myAreas = .Sheets("Packet Detail Report").Columns(1).SpecialCells(2).Areas
        For i = 1 To myAreas.Count
            If myAreas(i)(1).Font.Bold Then
                Set rng = myAreas(i).Resize(myAreas(i).Count + 1)
                ii = 1
                Do While i + ii <= myAreas.Count
                    If myAreas(i + ii)(1).Font.Bold Then Exit Do
                    Set rng = Union(rng, myAreas(i + ii))
                    ii = ii + 1
                Loop
                n = n + 1
                If n > .Sheets.Count - 1 Then .Sheets.Add after:=.Sheets(.Sheets.Count)
                With .Sheets(.Sheets.Count)
                    .Name = "Sheet" & n
                    myAreas.Parent.Parent.Cells.Copy .Cells(1)
                    .Cells.ClearContents
                    rng.EntireRow.Copy .Cells(1)
                End With
                i = i + ii - 1: Set rng = Nothing
            End If
        Next
    End With
    myAreas.Parent.Parent.Select
    Application.ScreenUpdating = True
End Sub

[taylorsm]

I get a subscription out of range error and it highlights ThisWorkbook.

[jindon]

.........................

[taylorsm]

Man I don't get it. It works in that workbook but mine it does not. The data/format is the same. I simply Control+F each individual column and replaced any cell with data with the other words. So why would one work and the other not?

[xlnitwit]

Hi,

If the error occurs on this line

ThisWorkbook.Sheets("Packet Detail Report").Copy before:=.Sheets(1)

the most likely reason is that the workbook which contains the code does not have a sheet called "Packet Detail Report" within it. You might start by checking for spelling differences and leading or trailing spaces in the sheet name.

[taylorsm]

Nope same spelling, my test workbook is the one that I created the example workbook from. I even copied the workbook name and pasted it to be sure. I then copied the name from the macro and pasted it into the sheet name. Same result.

[xlnitwit]

And the sheet is in the same workbook as the code?

[taylorsm]

No. All my codes are saved in my PERSONAL.XLSB file. Since the source file changes every month.

[taylorsm]

I did however "copy/move" the workbook into yours and it worked and quickly. So the code is awesome! if we can just get it to run through my PERSONAL.XLSB

[xlnitwit]

That is the issue. ThisWorkbook always refers to the workbook that contains the code. You must use either:

ActiveWorkbook.Sheets("Packet Detail Report").Copy before:=.Sheets(1)

or specify the actual workbook name in a call to the Workbooks collection.

[taylorsm]

Damn man, I hate being difficult. I deleted the words ThisWorkbook and typed in ActiveWorkbook and still got the same error

[xlnitwit]

Was the correct workbook active when you ran the code again?

[taylorsm]

Here is the workbook. All I did was replace the words with placeholds. Now I get the "out of range" error with the new text.

[taylorsm]

Yes, only have one workbook open, now I get a 1004 error, Method 'Add' of object 'Workbooks' failed

[xlnitwit]

I would recommend that you restart Excel and then try the code again. You should not be getting errors from basic lines like Workbooks.Add!

[taylorsm]

Back to "out of range"

[xlnitwit]

Please try this one

Sub test()
    Dim myAreas As Areas, i As Long, ii As Long, n As Long, rng As Range, wb as workbook
    Application.ScreenUpdating = False
    Set wb = activeworkbook
    With Workbooks.Add
        wb.Sheets("Packet Detail Report").Copy before:=.Sheets(1)
        Set myAreas = .Sheets("Packet Detail Report").Columns(1).SpecialCells(2).Areas
        For i = 1 To myAreas.Count
            If myAreas(i)(1).Font.Bold Then
                Set rng = myAreas(i).Resize(myAreas(i).Count + 1)
                ii = 1
                Do While i + ii <= myAreas.Count
                    If myAreas(i + ii)(1).Font.Bold Then Exit Do
                    Set rng = Union(rng, myAreas(i + ii))
                    ii = ii + 1
                Loop
                n = n + 1
                If n > .Sheets.Count - 1 Then .Sheets.Add after:=.Sheets(.Sheets.Count)
                With .Sheets(.Sheets.Count)
                    .Name = "Sheet" & n
                    myAreas.Parent.Parent.Cells.Copy .Cells(1)
                    .Cells.ClearContents
                    rng.EntireRow.Copy .Cells(1)
                End With
                i = i + ii - 1: Set rng = Nothing
            End If
        Next
    End With
    myAreas.Parent.Parent.Select
    Application.ScreenUpdating = True
End Sub

[taylorsm]

Hey xlnitwit that worked. Thanks!

[EssoExplJoe]

I use the following code to open workbooks and it doesn't allow the workbook to become the active workbook:

Application.ScreenUpdating = False
      Workbooks.Open wbook
      Application.ScreenUpdating = True
      Windows(wbookname).Visible = False

[taylorsm]

Sub test()
    Dim myAreas As Areas, i As Long, ii As Long, n As Long, rng As Range
    Application.ScreenUpdating = False
    With Workbooks.Add
        ActiveWorkbook.Sheets("Packet Detail Report").Copy before:=.Sheets(1)
        Set myAreas = .Sheets("Packet Detail Report").Columns(1).SpecialCells(2).Areas
        For i = 1 To myAreas.Count
            If myAreas(i)(1).Font.Bold Then
                Set rng = myAreas(i).Resize(myAreas(i).Count + 1)
                ii = 1
                Do While i + ii <= myAreas.Count
                    If myAreas(i + ii)(1).Font.Bold Then Exit Do
                    Set rng = Union(rng, myAreas(i + ii))
                    ii = ii + 1
                Loop
                n = n + 1
                If n > .Sheets.Count - 1 Then .Sheets.Add after:=.Sheets(.Sheets.Count)
                With .Sheets(.Sheets.Count)
                    .Name = "Sheet" & n
                    myAreas.Parent.Parent.Cells.Copy .Cells(1)
                    .Cells.ClearContents
                    rng.EntireRow.Copy .Cells(1)
                End With
                i = i + ii - 1: Set rng = Nothing
            End If
        Next
    End With
    myAreas.Parent.Parent.Select
    Application.ScreenUpdating = True
End Sub

[xlnitwit]

You're welcome. I realised- belatedly- that as soon as the new workbook was created it became the active one and hence the error you were getting.