Macro worked, but now crashes my workbook.

Had a macro built with this sites help and it worked perfectly. Until shortly ago. I haven't adjusted the code at all other than the name. The only thing i've done since working was share the workbook and lock it, but I have since unlocked it and unshared it.

Macro is as follows:

Sub CPR()
Dim dat As Date, dat2 As Date, lr As Long, lc As Long, i As Long, j As Long, x As Long, arr As Variant, sn As Variant
With Sheets("Result")
    .Range("A4", "XFD1000000").ClearContents
    If .Range("E1") < .Range("B1") Then .Range("E1") = .Range("B1")
    dat = .Range("B1").Value
    If .Range("E1") = "" Then
        dat2 = dat
    Else
        dat2 = .Range("E1").Value
    End If
End With
With Sheets("Totals")
    lc = .Cells(3, .Columns.Count).End(xlToLeft).Column
    For i = 1 To lc Step 5
        lr = .Cells(Rows.Count, i).End(xlUp).Row
        arr = .Range(.Cells(3, i), .Cells(lr, i + 4))
        ReDim sn(1 To UBound(arr), 1 To UBound(arr, 2))
        j = 0
        For x = 3 To UBound(arr)
            If arr(x, 1) >= dat And arr(x, 1) <= dat2 Then
                j = j + 1
                sn(j, 1) = arr(x, 1)
                sn(j, 2) = arr(x, 2)
                sn(j, 3) = arr(x, 3)
                sn(j, 4) = arr(x, 4)
                sn(j, 5) = arr(x, 5)
            End If
        Next
        If j > 0 Then Sheets("Result").Cells(4, i).Resize(j, UBound(sn, 2)) = sn
    Next
End With
End Sub

When I 'step into' the macro it breaks when I am on the ".Range("A4", "XFD1000000").ClearContents' and hit F8. That is when I get the spinning wheel.

I've never seen anyone actually use the last XFD column so that's a first!

My first thought is that whilst the original workbook was created with an Excel version > 2007 when the 16K columns were first introduced it has now been opened with a version of Excel prior to that which only has 256 columns. i.e. an .xls file

Why not change that line to

.UsedRange.ClearContents

Hello taylorsm,

Formula:

...breaks when I am on the ".Range("A4", "XFD1000000").ClearContents' and hit F8. That is when I get the spinning wheel.

That is a massive amount of Cells to run trough for any System!

Besides that, it will definitely crush on any System Running on Any Excel version prior to Excel 2007.

At best, please try the Code below. Maybe it will speed things up a bit.

Sub CPR()
Dim dat As Date, dat2 As Date, lr As Long, lc As Long, i As Long, j As Long, x As Long, arr As Variant, sn As Variant

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets("Result")
    .Range("A4", "XFD1000000").ClearContents
    If .Range("E1") < .Range("B1") Then .Range("E1") = .Range("B1")
    dat = .Range("B1").Value
    If .Range("E1") = "" Then
        dat2 = dat
    Else
        dat2 = .Range("E1").Value
    End If
End With
With Sheets("Totals")
    lc = .Cells(3, .Columns.Count).End(xlToLeft).Column
    For i = 1 To lc Step 5
        lr = .Cells(Rows.Count, i).End(xlUp).Row
        arr = .Range(.Cells(3, i), .Cells(lr, i + 4))
        ReDim sn(1 To UBound(arr), 1 To UBound(arr, 2))
        j = 0
        For x = 3 To UBound(arr)
            If arr(x, 1) >= dat And arr(x, 1) <= dat2 Then
                j = j + 1
                sn(j, 1) = arr(x, 1)
                sn(j, 2) = arr(x, 2)
                sn(j, 3) = arr(x, 3)
                sn(j, 4) = arr(x, 4)
                sn(j, 5) = arr(x, 5)
            End If
        Next
        If j > 0 Then Sheets("Result").Cells(4, i).Resize(j, UBound(sn, 2)) = sn
    Next
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Regards,

Building on Richard's and Winons replies:

if you replace the .clear contents line with:

Dim r As Range

Set r = ActiveSheet.UsedRange
Set r = r.Offset(3, 0)
r.ClearContents

It will do only as much work as there is to do.

Also if you put in the

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

remember to undo it afterwards:

Application.ScreenUpdating = true
Application.Calculation = xlCalculationAutomatic

Originally Posted by tony h

Building on Richard's and Winons replies:

if you replace the .clear contents line with:

Dim r As Range

Set r = ActiveSheet.UsedRange
Set r = r.Offset(3, 0)
r.ClearContents

Neat. An excellent suggestion

You said it crashed. Does it come up with an error message? Or are you, as before, getting the spinning wheel?


Also when you reply could you
1. report what happens if you change the line to

.Range("A4", "D10").ClearContents

It won't clear the whole area but it would just check a few things.
2. report how big the file is and whether it seems over large. I suspect that the run of the code previously may have swollen the file which would cause the .usedrange to run slowly as well.

Do you mean replace

With Sheets("Result")
    .Range("A4", "XFD1000000").ClearContents
    If .Range("E1") < .Range("B1") Then .Range("E1") = .Range("B1")

with

With Sheets("Result")
Dim r As Range
Set r = ActiveSheet.UsedRange
Set r = r.Offset(3, 0)
r.ClearContents
If .Range("E1") < .Range("B1") Then .Range("E1") = .Range("B1")

I tried this and it seems to work...

Sub CPR()
Dim dat As Date, dat2 As Date, lr As Long, lc As Long, i As Long, j As Long, x As Long, arr As Variant, sn As Variant
Dim r As Range

Set r = ActiveSheet.UsedRange
Set r = r.Offset(3, 0)

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets("Result")
     r.ClearContents
    If .Range("E1") < .Range("B1") Then .Range("E1") = .Range("B1")
    dat = .Range("B1").Value
    If .Range("E1") = "" Then
        dat2 = dat
    Else
        dat2 = .Range("E1").Value
    End If
End With
With Sheets("Totals")
    lc = .Cells(3, .Columns.Count).End(xlToLeft).Column
    For i = 1 To lc Step 5
        lr = .Cells(Rows.Count, i).End(xlUp).Row
        arr = .Range(.Cells(3, i), .Cells(lr, i + 4))
        ReDim sn(1 To UBound(arr), 1 To UBound(arr, 2))
        j = 0
        For x = 3 To UBound(arr)
            If arr(x, 1) >= dat And arr(x, 1) <= dat2 Then
                j = j + 1
                sn(j, 1) = arr(x, 1)
                sn(j, 2) = arr(x, 2)
                sn(j, 3) = arr(x, 3)
                sn(j, 4) = arr(x, 4)
                sn(j, 5) = arr(x, 5)
            End If
        Next
        If j > 0 Then Sheets("Result").Cells(4, i).Resize(j, UBound(sn, 2)) = sn
    Next
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Hello taylorsm,

...the 10:42 post...

It is actually better to quote by Post Number, to avoid time differences across the Globe.

Regards.

Hi taylorsm,

Glad you finally managed to get your issue resolved.

Thank you so much for the "Rep"!

Regards

I am glad it worked for you just a couple of suggestions: one cosmetic and one functional

Set r = ActiveSheet.UsedRange
Set r = r.Offset(3, 0)

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets("Result")
     r.ClearContents

with this:
Notes:
1. the cosmetic element is changing the position of some of the code
2. the functional is to ensure that the code uses the named sheet Result. This could be done by changing ActiveSheet to Sheets("Result") or as I have here by letting the .UsedRange pick up the sheet from the with clause.

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets("Result")
     Set r = .UsedRange
     Set r = r.Offset(3, 0)
     r.ClearContents

That's it, my man!!!