Help with my code to split data to worksheets

[vedderman]

I have this code that I'm certain I took from this board last year and have used successfully many times to split data to worksheets by unique values in a column. I'm trying to use it now and it's working, but with errors. Some of my "unique" data has more than 31 characters and the code is leaving those items out of their sheets.

How do I edit this code to omit renaming the worksheets and just leave them as Sheet2-Sheet#.

Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 4
Set ws = Sheets("Data")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:Z3"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

 

[Fluff]

If you don't rename the sheets, how does the macro know which sheet to copy the data to next time you run it?

 

[vedderman]

If you don't rename the sheets, how does the macro know which sheet to copy the data to next time you run it?

This is ad-hoc reporting. The macro creates a new workbook each time I run it. The data is always new each month.

I've got it to function using a workaround of finding and replacing the text in column D that was greater than 31 characters. Works just as efficiently.

 

[Fluff]

If you've sorted it, that's great.
For reference, to answer you original question, you'd do it like this

For i = 2 To UBound(myarr)
   ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
   Sheets.Add after:=Worksheets(Worksheets.Count)
   ws.Range("A" & titlerow & ":A" & LR).EntireRow.Copy ActiveSheet.Range("A1")
   ActiveSheet.Columns.AutoFit
Next

 

[vedderman]

If you've sorted it, that's great.
For reference, to answer you original question, you'd do it like this

For i = 2 To UBound(myarr)
   ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
   Sheets.Add after:=Worksheets(Worksheets.Count)
   ws.Range("A" & titlerow & ":A" & LR).EntireRow.Copy ActiveSheet.Range("A1")
   ActiveSheet.Columns.AutoFit
Next

Thanks. I'll probably copy this into my code anyway for the next time I have this issue.