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 ...
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:
