Error '1004' Sort method of range class failed

Davavo

Board Regular
Joined
Aug 3, 2019
Messages
76
Can anyone figure out why this fails?
I have done everything i can think of to make sure there is nothing to bother it.
I have run it with the header cleared, I have deleted all rows with any illegal characters. Ii have added a little sub to do this too.

I am using a script i that creates sheets from filtered lists. Unfortunately, it is indecipherable to me.
I have got it running on two other sheets but this one is stubborn.

I would actually prefer to use a different, more easily understood script for doing the sheets form filter job, so if anyone knows one that works well, please point me at it.
Otherwise, if anyone can suggest a reason for failure that i could test i would appreciate it.

Thanks in advance for any help.


Full script is here ...
Code:
 Option Explicit

Const sname As String = "INVRead" 'change to whatever starting sheet
Const s As String = "I" 'change to whatever criterion column




Sub columntosheetsINV()


Dim wb As Workbook
Dim sh As Worksheet




Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set wb = ThisWorkbook
Set d = CreateObject("scripting.dictionary")


With wb.Sheets(sname)
    rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    cc = .Columns(s).Column
End With


For Each sh In Worksheets
    d(sh.Name) = 1
Next sh


Application.ScreenUpdating = False
With wb.Sheets.Add(after:=wb.Sheets(sname))
wb.Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes '-----------------------------------------------------------------error is always here!!
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
    If a(i, 1) <> a(p, 1) Then
        If d(a(p, 1)) <> 1 Then
            Sheets.Add.Name = a(p, 1)
            .Cells(1).Resize(, cls).Copy Cells(1)
            .Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
        End If
        p = i
    End If
Next i
Application.DisplayAlerts = False
    .Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
wb.Sheets(sname).Activate


End Sub


Function FileExists(FilePath As String) As Boolean
Dim TestStr As String
    TestStr = ""
    On Error Resume Next
    TestStr = Dir(FilePath)
    On Error GoTo 0
    If TestStr = "" Then
        FileExists = False
    Else
        FileExists = True
    End If
End Function
Sub FilterINV()


Dim NewName As String
Dim LastRow As Long
Dim strFile As String
Dim listob As ListObject
Dim strDir As String
Dim NewBook As Workbook
Dim ws As Worksheet




'turn off hogs
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False




With Application
         
'returns to retry in case filename is same as previous.  


retry:
    
 'Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook")
            
'in case of cancelation messagebox


If StrPtr(NewName) = 0 Then


    MsgBox ("User canceled!")
    GoTo reset
        
Else
End If
        
    
    'create a directory for this type of record.  Each type of record (CCCard, Invoice, Expense claim) should have its own directory
    strDir = ThisWorkbook.path & "\InvoiceRecords\"
    
    'check if directory exists, make on if its doesn't.
    If Dir(strDir, vbDirectory) = "" Then
        MkDir strDir
    Else
    End If
    
    
    'VBA Check if File Exists using the FileExists Function
    strFile = strDir & NewName & ".xlsx"
        
    'alternate method not currerntly in use ..................'strFile = GetFolder & "\" & NewName & ".xlsx"
    
    If FileExists(strFile) Then
        'File Exists
        MsgBox "The filename you have chosen already exists, please choose a unique filename"
            
GoTo retry
        
        Else
        'no need for anything if file does not already exist
        End If
End With


'create a new workbook defined as NewBook
Set NewBook = Workbooks.Add


With NewBook


        .title = NewName 'name of new workbook
        .Subject = "Expenses In WorkSheets arranged by Cost Centre or Task Code"
        
                'whole bunch of alternative saving methods
                '-------------------------------------------------------------------------
                    
                    '.SaveAs ThisWorkbook.path & "\" & NewName & ".xlsx"
                    '.SaveAs GetFolder & "\" & NewName & ".xlsx"
                    'FullPath = GetFolder & "\" & NewName
                    
                    'If MsgBox("Save With Time Stamp?" _
                        , vbYesNo, "NewCopy") = vbNo Then
                            '.SaveAs strFile
                    'Else
                '-------------------------------------------------------------------------


                Application.EnableEvents = False
                Application.Calculation = xlCalculationManual
                Application.ScreenUpdating = False


                'Save it with the NewName and in the same directory as the tool
                .SaveAs strDir & NewName & Format(Now(), " dd-mm-yy-hh-mm-ss-AMPM") & ".xlsx"
                
                'redefine NewName to include the timestamp
                NewName = NewName & Format(Now(), " dd-mm-yy-hh-mm-ss-AMPM")




                '-------------
                'End If
                '-------------
                
End With 'ends the with NewBook


Workbooks("Expenses.xlsm").Sheets("INVRead").Activate



'------------------------------------------------------------------------------------------------


Call ReplaceIllegalCharacters 'look through the filter column and replace '/' with "" .... I have tested '|' (pipe) too as well as just removing


'------------------------------------------------------------------------------------------------








'------------------------------------------------------------------------------------------------


Call columntosheetsINV 'filter column and copy to separate sheets '---------------------------------------THIS IS THE CALL FOR IT


'------------------------------------------------------------------------------------------------


'look at each worksheet in this workbook and if it is one of the ones produced by the above sub 'columtosheets', copy it to a new workbook
For Each ws In ThisWorkbook.Worksheets


        Select Case ws.Name
            Case "Dashboard", "Expenses", "CCRead", "INVRead"  'list the sheets NOT to copy
            Case Else
            'copy the rest
                
                With Workbooks("Expenses.xlsm")
                    ws.Copy Before:=Workbooks(NewName & ".xlsx").Sheets(1)
                End With
        End Select
Next


'activate the new workbook and delete the sheet named "Sheet1" so that only the sheets created by the script are present
Workbooks(NewName & ".xlsx").Activate


'disable alerts so as not to get the pop up asking to confirm deletion of the sheet
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True




'delete the sheets from the main workbook
    For Each ws In ThisWorkbook.Worksheets
            Select Case ws.Name
                Case "Dashboard", "Expenses", "CCRead", "INVRead"  'list the sheets NOT to be deleted
                Case Else
                'delete the rest
                    With Workbooks("Expenses.xlsm")
                        'disable alerts so as not to get the pop up asking to confirm deletion of the sheet
                        Application.DisplayAlerts = False
                        ws.Delete
                        Application.DisplayAlerts = True
                    End With
            End Select
    Next




'create named tables on the sheets of the new workbook and add the totals columns


For Each ws In Workbooks(NewName & ".xlsx").Worksheets
      Select Case ws.Name
         Case "Dashboard", "Expenses", "CCRead", "INVRead"  'list the sheets NOT to be worked on
         Case Else
         ws.Activate
            ws.ListObjects.Add(1, ws.Cells(1).CurrentRegion, , 1).Name = "INVRecords" & ActiveSheet.Name
            With ws.ListObjects("INVRecords" & ActiveSheet.Name)
               ws.Columns("K").ColumnWidth = 15
               .ShowTotals = True
               .ListColumns("VAT Amount").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Total Invoice Value").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Invoice Value Net").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Invoice Type").TotalsCalculation = xlTotalsCalculationCount
               .ListColumns("Task").TotalsCalculation = xlTotalsCalculationCount
               .ListColumns("Payment Date").TotalsCalculation = xlTotalsCalculationNone
            End With
      End Select
   Next




reset:
'Reset hoggs
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


End Sub
 
Last edited:

Some videos you may like

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

Watch MrExcel Video

Forum statistics

Threads
1,126,993
Messages
5,622,049
Members
415,875
Latest member
Tarali

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
Top