Run time error (I believe) is causing Excel to crash

K

kingconsto

New Member
Joined
Apr 19, 2017
Messages
32
Hi All,

I have what I believe to be a basic marco which usually runs fine but at times the code seems to get stuck in a loop and I have to force excel to close. Is the code in a bad format? How can I fix this issue? I believe it might have something to do with the loop or "On Error Resume Next" Appreciate the help!

Code: 
Sub TREATS()
'
' TREATS Macro
'
Dim s, so, macname As String
Dim marker As Integer
Const ForReading = 1, ForWriting = 2, ForAppending = 3
    Sheets("Data").Select
    Range("AK9:EQ33").Select
    'Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("Treats").Select
    Range("A3").Select
    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Treats").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Treats").Sort.SortFields.Add Key:=Range("A3"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Treats").Sort
        .SetRange Range("A3:DG17")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("Treats").Select
    Range("A3").Select
    
      StaffID = InputBox("Please enter staff ID")
macname = "C:\Users" & StaffID & "\AppData\Roaming\IBM\Personal Communications\benelux.mac"
Set so = CreateObject("Scripting.FileSystemObject")
    so.CreateTextFile macname
Set s = so.OpenTextFile(macname, ForWriting)
    s.writeline "Description ="
marker = 3
Do While Cells(marker, 1) <> "N"
    s.writeline Cells(marker, 2).Value
    s.writeline Cells(marker, 3).Value
    s.writeline Cells(marker, 4).Value
    s.writeline Cells(marker, 5).Value
    s.writeline Cells(marker, 6).Value
    s.writeline Cells(marker, 7).Value
    s.writeline Cells(marker, 8).Value
    s.writeline Cells(marker, 9).Value
    s.writeline Cells(marker, 10).Value
    s.writeline Cells(marker, 11).Value
    s.writeline Cells(marker, 12).Value
    s.writeline Cells(marker, 13).Value
    s.writeline Cells(marker, 14).Value
    s.writeline Cells(marker, 15).Value
    s.writeline Cells(marker, 16).Value
    s.writeline Cells(marker, 17).Value
    s.writeline Cells(marker, 18).Value
    s.writeline Cells(marker, 19).Value
    s.writeline Cells(marker, 20).Value
    s.writeline Cells(marker, 21).Value
    s.writeline Cells(marker, 22).Value
    s.writeline Cells(marker, 23).Value
    s.writeline Cells(marker, 24).Value
    s.writeline Cells(marker, 25).Value
    s.writeline Cells(marker, 26).Value
    s.writeline Cells(marker, 27).Value
    s.writeline Cells(marker, 28).Value
    s.writeline Cells(marker, 29).Value
    s.writeline Cells(marker, 30).Value
    s.writeline Cells(marker, 31).Value
    s.writeline Cells(marker, 32).Value
    s.writeline Cells(marker, 33).Value
    s.writeline Cells(marker, 34).Value
    s.writeline Cells(marker, 35).Value
    s.writeline Cells(marker, 36).Value
    s.writeline Cells(marker, 37).Value
    s.writeline Cells(marker, 38).Value
    s.writeline Cells(marker, 39).Value
    s.writeline Cells(marker, 40).Value
    s.writeline Cells(marker, 41).Value
    s.writeline Cells(marker, 42).Value
    s.writeline Cells(marker, 43).Value
    s.writeline Cells(marker, 44).Value
    s.writeline Cells(marker, 45).Value
    s.writeline Cells(marker, 46).Value
    s.writeline Cells(marker, 47).Value
    s.writeline Cells(marker, 48).Value
    s.writeline Cells(marker, 49).Value
    s.writeline Cells(marker, 50).Value
    s.writeline Cells(marker, 51).Value
    s.writeline Cells(marker, 52).Value
    s.writeline Cells(marker, 53).Value
    s.writeline Cells(marker, 54).Value
    s.writeline Cells(marker, 55).Value
    s.writeline Cells(marker, 56).Value
    s.writeline Cells(marker, 57).Value
    s.writeline Cells(marker, 58).Value
    s.writeline Cells(marker, 59).Value
    s.writeline Cells(marker, 60).Value
    s.writeline Cells(marker, 61).Value
    s.writeline Cells(marker, 62).Value
    s.writeline Cells(marker, 63).Value
    s.writeline Cells(marker, 64).Value
    s.writeline Cells(marker, 65).Value
    s.writeline Cells(marker, 66).Value
    s.writeline Cells(marker, 67).Value
    s.writeline Cells(marker, 68).Value
    s.writeline Cells(marker, 69).Value
    s.writeline Cells(marker, 70).Value
    s.writeline Cells(marker, 71).Value
    s.writeline Cells(marker, 72).Value
    s.writeline Cells(marker, 73).Value
    s.writeline Cells(marker, 74).Value
    s.writeline Cells(marker, 75).Value
    s.writeline Cells(marker, 76).Value
    s.writeline Cells(marker, 77).Value
    s.writeline Cells(marker, 78).Value
    s.writeline Cells(marker, 79).Value
    s.writeline Cells(marker, 80).Value
    s.writeline Cells(marker, 81).Value
    s.writeline Cells(marker, 82).Value
    s.writeline Cells(marker, 83).Value
    s.writeline Cells(marker, 84).Value
    s.writeline Cells(marker, 85).Value
    s.writeline Cells(marker, 86).Value
    s.writeline Cells(marker, 87).Value
    s.writeline Cells(marker, 88).Value
    s.writeline Cells(marker, 89).Value
    s.writeline Cells(marker, 90).Value
    s.writeline Cells(marker, 91).Value
    s.writeline Cells(marker, 92).Value
    s.writeline Cells(marker, 93).Value
    s.writeline Cells(marker, 94).Value
    s.writeline Cells(marker, 95).Value
    s.writeline Cells(marker, 96).Value
    s.writeline Cells(marker, 97).Value
    s.writeline Cells(marker, 98).Value
    s.writeline Cells(marker, 99).Value
    s.writeline Cells(marker, 100).Value
    s.writeline Cells(marker, 101).Value
    s.writeline Cells(marker, 102).Value
    s.writeline Cells(marker, 103).Value
    s.writeline Cells(marker, 104).Value
    s.writeline Cells(marker, 105).Value
    s.writeline Cells(marker, 106).Value
    s.writeline Cells(marker, 107).Value
    s.writeline Cells(marker, 108).Value
    s.writeline Cells(marker, 109).Value
    s.writeline Cells(marker, 110).Value
    s.writeline Cells(marker, 111).Value
    marker = marker + 1
    On Error Resume Next
Loop
MsgBox ("BENELUX MACRO CREATED")
End Sub
 
Last edited by a moderator:

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
Do you ever have a situation where column A might not have an N in it? Note: for this code, 'n' is not the same as 'N'. It would be safer to limit the Do Loop so that it can't go past the last row that might have data.

I'm also unclear as to why you copy 25 rows but then only sort 15?
 
Last edited:
Upvote 0
I have changed the sort to include all 25 rows.

Non of the data being copied in column A has an "N" in it except one. It looks like this:

[TABLE="width: 500"]
<tbody>[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD]N
[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
[TR]
[TD][pf1]
[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 64"]
<tbody>[TR]
[TD="width: 64, bgcolor: transparent"][/TD]
[/TR]
[TR]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"][/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
[TR]
[TD="bgcolor: transparent"]
[/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited:
Upvote 0
Cannot see anything immediately wrong with the code, but try the following (untested) and if it errors, reply with the error message and what line is highlighted yellow:
Code: 
Sub Treats_v1()

    Dim arr()   As Variant
    Dim strFile As Variant
    Dim str     As String
    Dim x       As Long
    Dim y       As Long
    
    str = InputBox("Please enter staff ID:")
    str = Replace("C:\Users@1\AppData\Roaming\IBM\Personal Communications\benelux.mac", "@1", str)
    
    Application.ScreenUpdating = False

    arr = Sheets("Data").Range("AK9:EQ33").Value
    
    With Sheets("Treats")
        .Range("A3").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        With .Sort
            .SortFields.Clear
            .SortFields.add key:=.Range("A3"), SortOn:=xlSortOnValues, Order:=xlAscending
            .SetRange .Range("A3:DG17")
            .header = xlNo
            .MatchCase = False
            .Orientation = XlTopBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        x = .Cells(.Rows.Count, 1).End(xlUp).row

        On Error Resume Next
        x = .Cells(1, 1).Resize(x).find(what:="N", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True).row
        On Error Goto 0
        If .Cells(x, 1).Value <> "N" Then
            Erase arr
            Application.ScreenUpdating = True
            MsgBox "Cannot find N value in column A, please check and try again", vbExclamation, "Missing Value"
            Exit Sub
        End If
        Erase arr
        arr = .Cells(3, 1).Resize(x - 2, 111).Value
    End With
           
    With CreateObject("Scripting.FileSystemObject")
        .createtextfile str
        Set strFile = .opentextfile(str, ForWriting)
        strFile.writeline "Description ="
        For x = LBound(arr, 1) To UBound(arr, 1)
            For y = LBound(arr, 2) To UBound(arr, 2)
                s.writeline arr(x, y)
            Next y
        Next x
    End With

    Application.ScreenUpdating = True
   
    MsgBox ("BENELUX MACRO CREATED")
    
    Set strFile = Nothing
    Erase arr
    
End Sub
 
Last edited:
Upvote 0
It should be xlTopToBottom as in your original.
 
Upvote 0
Perils of not using copy & paste and with untested code, thanks for spot RoryA
 
Upvote 0
Ok. got it. The error is Run-time error '438': Object doesn't support this property or method.
.SortFields.Add Key:=.Range("A3"), SortOn:=xlSortOnValues, Order:=xlAscending
 
Upvote 0
Changed it around, I think I've had a problem with .Sort in a With statement before, probably the .Range("A3") part wasn't a child of the With .Sort. Anyway, try:
Code: 
Sub Treats_v1()

    Dim arr()   As Variant
    Dim strFile As Variant
    Dim str     As String
    Dim x       As Long
    Dim y       As Long
    
    str = InputBox("Please enter staff ID:")
    str = Replace("C:\Users@1\AppData\Roaming\IBM\Personal Communications\benelux.mac", "@1", str)
    
    Application.ScreenUpdating = False

    arr = Sheets("Data").Range("AK9:EQ33").Value
    
    With Sheets("Treats")
        .Range("A3").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        .Sort.SortFields.Clear
        .Sort.SortFields.add key:=.Range("A3"), SortOn:=xlSortOnValues, Order:=xlAscending
        x = .Cells(.Rows.Count, 1).End(xlUp).row
        With .Sort
            .SetRange .Range("A3:DG" & x)
            .header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        On Error Resume Next
        x = .Cells(1, 1).Resize(x).find(what:="N", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True).row
        If .Cells(x, 1).Value <> "N" Then
            MsgBox "Cannot find N value in column A, please check and try again", vbExclamation, "Missing Value"
            Exit Sub
        End If
        Erase arr
        arr = .Cells(3, 1).Resize(x - 2, 111).Value
    End With
           
    With CreateObject("Scripting.FileSystemObject")
        .createtextfile str
        Set strFile = .opentextfile(str, ForWriting)
        strFile.writeline "Description ="
        For x = LBound(arr, 1) To UBound(arr, 1)
            For y = LBound(arr, 2) To UBound(arr, 2)
                s.writeline arr(x, y)
            Next y
        Next x
    End With
   
    MsgBox ("BENELUX MACRO CREATED")
    
    Set strFile = Nothing
    Erase arr
    
End Sub
 
Last edited:
Upvote 0
Still won't work as this line:

Code: 
.SetRange .Range("A3:DG" & x)

is linking the range back to the Sort object, not the worksheet. Try:

Code: 
.SetRange .Parent.Range("A3:DG" & x)
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Locked
  • Question Question
Vba code for User history log which is giving me a run-time error "13" mismatch
Replies
2
Views
148
Fluff
Fluff
J
  • Question Question
Using Sheets().Select in a Worksheet_Activate() macro
2
Replies
10
Views
445
jdun
J
M
  • Question Question
Run time error 1004: Application defined or object defined error
Replies
1
Views
521
Micron
M
S
  • Question Question
Macro crashes since update of excel to v.2408.
Replies
2
Views
168
Saab95
S
L
  • Solved
Adding empty lines based on value via “I” loop which crashes and lags
2
Replies
10
Views
388
Joe4
Joe4

Forum statistics

Threads
1,223,886
Messages
6,175,194
Members
452,616
Latest member
intern444

Share this page

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
Back
Top