VBA: Split data into multiple worksheets based on column

[waxsublime]

I'm trying to get this code I found (from How to split data into multiple worksheets based on column in Excel?) to work, but it's giving me an error.

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("Sheet1")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:I1"
    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

Any ideas on how to fix this?

Thanks!

 

[mirabeau]

I'm trying to get this code I found (from How to split data into multiple worksheets based on column in Excel?) to work, but it's giving me an error.

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("Sheet1")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:I1"
    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) & ""
   [COLOR=#ff0000] If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
 Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""[/COLOR]
    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

Any ideas on how to fix this?

Thanks!

There's lot's of other codes around that do this sort of thing. Most run faster and without error.

If for any reason you're enthusiastic about the above, then modify as indicated in red, i.e. in your version just press Enter after the Then, so code should have that line ending in Then and next line starting with Sheets.Add ...

 

[waxsublime]

Wow, thanks so much mirabeau! That worked like a charm!

Do you have a favorite version of this that you would recommend? If so, please share. I'd love to check it out.

Thanks again!

 

[mirabeau]

Wow, thanks so much mirabeau! That worked like a charm!

Do you have a favorite version of this that you would recommend? If so, please share. I'd love to check it out.

Thanks again!

Really depends on the data and the problem.
You could try this one and see if it works for you

Sub columntosheets() 

Const sname As String = "Sheet1" 'change to whatever starting sheet
Const s As String = "A" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With 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 Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
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
Sheets(sname).Activate

End Sub

 

[waxsublime]

Thanks mirabeau. That macro is a LOT faster. But it's giving me an error on the name for the sheet:

Runtime 1004:
Name can't exceed 31 char
name cannot contain characters: : /\?*
You did not leave the name blank

The other macro didn't give the error, but I also haven't checked to see if it did everything correctly. Anyway, thanks again!

 

[mirabeau]

Thanks mirabeau. That macro is a LOT faster. But it's giving me an error on the name for the sheet:

Runtime 1004:
Name can't exceed 31 char
name cannot contain characters: : /\?*
You did not leave the name blank

The other macro didn't give the error, but I also haven't checked to see if it did everything correctly. Anyway, thanks again!

The code in Post#4 aimed to name the new sheets after the unique items in Column A.

If any or all of these items have more than 31 characters (say because they contain non-printing characters or other reason) then Excel won't do this.

Neither can the code you initially posted. That code just bypasses the error by including an "On Error Resume Next" line about halfway down, in which case the new sheets are just given sheet numbers.

If you want the code I posted to likewise bypass the error and produce that same result, then likewise just include an "On Error Resume Next" about halfway down (say just before the line "a = .Cells(cc).Resize(rws + 1, 1)").

Personally I prefer to not follow that approach. If there's a potential error, caused by data type or whatever, my preference to see just what that error is and then take remedial action, rather than automatically just bypassing any and all errors.

In your case I had no idea of what type of data you had so, as often when doing this sort of thing, some guesswork was needed as to both your data and the nature of result you wanted.

 

[waxsublime]

Oh okay, I see. Thanks for the explanation. I really appreciate the help!

 

[fjlaff]

Hi mirabeau,

I'm new here and a complete novice with macros. The code you posted has worked for me, however the names are all in reverse order, and there are some other functions I need to add. It would be very helpful if you could explain each step of the macro so I can adjust from there.

Regards,
Fearghas

 

[mirabeau]

Hi mirabeau,

I'm new here and a complete novice with macros. The code you posted has worked for me, however the names are all in reverse order, and there are some other functions I need to add. It would be very helpful if you could explain each step of the macro so I can adjust from there.

Regards,
Fearghas

hi Fearghas,

welcome to the forum.

I'm unsure what you mean by "the names are all in reverse order"

If colA is your starting or criterion column, and you have A, B, C listed down it then that code generates and lists new sheets named A, B and C, in that order.

if you are a "complete" novice it's a moderately complex macro to explain, and perhaps better if you familiarized yourself more with some simpler ones first.

also, as noted above, there's a variety of vba codes around that do this sort of thing. for example in these links

http://www.mrexcel.com/forum/excel-...s-move-rows-another-sheet-based-criteria.html
http://www.mrexcel.com/forum/excel-questions/328460-copy-various-duplicate-rows-new-sheet.html

and plenty of elsewheres.

 

[fjlaff]

Hi mirabeau,

Sorry, I meant to say the produced sheet names are in reverse alphabetical order. I can deal with complex, and I have done some tutorials on macros and vba but there is nothing beyond the basic in the tutorials, and I only really need the macro for one specific function, after that I can learn in my own time.

Thanks for the help and the links