Sub LoopingSheetName() (1 Viewer)

[DanG]

Hello,
I have a some code from the following site that keeps giving me a "type mismatch" error. I have used this code with sucess quite a while ago and don't remember having this sort of problem.

The code is supposed to look at column A and based on unique values make new sheets within the workbook for each unique value. It doesn't mater what data I put in the cells, I get the error. I even just used one column with a header and 4 sample values under the header as follows:
Name
Dan
Dan
Bil
Jim

Here is the code:

Sub LoopingSheetName()
'By Thomas Urtis

'Prepare Excel
Application.ScreenUpdating = False
ActiveSheet.AutoFilterMode = False

'Declare your one worksheet as a source sheet variable
Dim SourceSheet As Worksheet
Set SourceSheet = Worksheets("Sheet1")

'Make sure you start from the source sheet (modify name if needed)
SourceSheet.Activate

'Declare filter range variable, from column A to column E (modify column range as needed)
Dim FilterRange As Range
Set FilterRange = Range(("A1"), Cells(Rows.Count, 1).End(xlUp).Offset(0, 4))

'Sort the range in ascending order so we do not add sheets for duplicate names
FilterRange.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

'Start in cell A2
Range("A2").Activate

'Loop down column A to determine identical values (names).
'Filter each unique name set.
'Create a new sheet and copy each filtered recordset to its respective new sheet
Do
If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then
ActiveCell.Offset(1, 0).Activate
Else
FilterRange.AutoFilter Field:=1, Criteria1:=ActiveCell.Value
SourceSheet.Range("Z1").Formula = "=RIGHT(FilterCriteria(Sheet1!R2C1),LEN(FilterCriteria(Sheet1!R2C1))-SEARCH(""="",FilterCriteria(Sheet1!R2C1)))"
Dim NewSheetName As String
NewSheetName = SourceSheet.Range("Z1").Value
With Worksheets.Add(after:=Sheets(Sheets.Count))
Application.DisplayAlerts = False
On Error Resume Next
Worksheets(NewSheetName).Delete
On Error GoTo 0
Application.DisplayAlerts = True
.Name = NewSheetName
SourceSheet.Activate
FilterRange.SpecialCells(xlCellTypeVisible).Copy Worksheets(NewSheetName).Range("A1")
SourceSheet.AutoFilterMode = False
End With
ActiveCell.Offset(1, 0).Activate
End If
Loop While Len(ActiveCell) <> 0

'Re-set Excel
Range("Z1").ClearContents
Application.Goto Range("A1"), True
Application.ScreenUpdating = True

End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''

Function FilterCriteria(Rng As Range) As String
'By Stephen Bullen
Dim Filter As String
Filter = ""
On Error GoTo Finish
With Rng.Parent.AutoFilter
If Intersect(Rng, .Range) Is Nothing Then GoTo Finish
With .Filters(Rng.Column - .Range.Column + 1)
If Not .On Then GoTo Finish
Filter = .Criteria1
Select Case .Operator
Case xlAnd
Filter = Filter & " AND " & .Criteria2
Case xlOr
Filter = Filter & " OR " & .Criteria2
End Select
End With
End With
Finish:
FilterCriteria = Filter
End Function

Any help would be great!

 

[boblarson]

Comment out any error handlers and when the error message comes up, click DEBUG and tell us which line it highlights.

 

[DanG]

Comment out any error handlers and when the error message comes up, click DEBUG and tell us which line it highlights.

Thank you for the reply Bob.
I am not very experienced at code and least of all debugging, but I gave it a try. I commented out anything that said "on error" which were 2 instances on the first code set and then the 1 instance on the second code set (at the bottom). Then I ran the debugger and just got the same "type mismatch" error as before. The only choice I had from the error box was to say "ok" or "help".

Update:
I did the run code to curser and the error message showed up at this line:

SourceSheet.Range("Z1").Formula = "=RIGHT(FilterCriteria(Sheet1!R2C1),LEN(FilterCriteria(Sheet1!R2C1))-SEARCH(""="",FilterCriteria(Sheet1!R2C1)))"