Split data into multiple worksheet based on column variables - edited from online sources

Data2Worksheets.vbs

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

'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.

Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
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
Application.ScreenUpdating = True
End Sub

Hi - thank you for this code as I have used it with slight mod and worked perfectly, though did throw an error when naming the tabs due to the length of some of the cell contents i.e >31 characters. I CAN do it as a separate small VB but can you advise if it can be added to this code - which would be neater - regards Tom C

Sorry - should have been clearer - I have used the original VB code "Sub parse_data()" - Regards Tom C.

@Gandalf-3 That sounds like a good idea. We can add a conditional in the current line 32 (Sheets.Add) that truncates the string if it gets beyond 31 characters, or something similar. Have you written a snippet? I could update the changes here and mention you as a contributor here if you're happy with that.

Since this is a gist and is not designed for collaboration, I could add it to https://github.com/martinctc/Excel-VBA and we can collaborate properly on there as well.

Hi, not a programmer but I found this script via this tutorial: https://www.excelhow.net/split-data-into-multiple-worksheets-based-on-column.html and after testing, it is going to work AMAZINGLY for manipulating/automating our massive circulation list for our school library (which "dumps" from the database as a single-worksheet csv, mass-of-data nightmare), EXCEPT that it's returning blank worksheets for any strings that contain special characters.

(Above screenshot is of a small sample dataset with private info removed- the main screen shows the worksheet I started with, with the tabs at the bottom & in the worksheet list having been created by the script. Note that blank sheets start at 41 only because of previous tests on same file.)

Is there a way to change this VBA code so that it works with special characters? Or will we have to find & replace each special character before running the macro each time? (The initial data export will always have special characters, unfortunately.)

Any advice would be truly GREATLY appreciated and thank you also for the starting script!

Hi, not a programmer ...
EXCEPT that it's returning blank worksheets for any strings that contain special characters.....

Is there a way to change this VBA code so that it works with special characters? Or will we have to find & replace each special character before running the macro each time?

@LGEponine

I was running into a similar issue whilst doing inventory of my Docker Images. Upon looking into it I noticed the issue is related to line 32

Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""

Explaination

For context, i've never worked with VB before looking at this, so forgive any misnomers and mistakes 🙏😅

Typically, Excel will display an error if a user attempts to name a sheet with invalid characters:

When this same action is attempted in VB, we see the following:

Name without special characters

Name WITH special characters

However, on line 22 we can see On Error Resume Next. This tells Excel to ignore any errors and continue with the script. The reason this is included is due to Application.WorksheetFunction.Match being used on line 23, as this function throws an error if it does not find a valid match to the provided string.

Image source

Unfortunately, the result of this is that the naming error is also ignored.

You'll notice in the screenshot that 'Sheet 5' appears. This is the name of the WorkSheet the Add function created. Because the name property set via the Sheets.Add.Name command on line 32 is not valid, Excel does not update the name. You can see this in your own screenshot.

Notice how 'Gladwell - Outliers' and 'Zimmerman - Metamorphosis' are correctly named, but everything else is named 'Sheet XX' (where XX is the sequential number). This means that our sheets names are not being updated correctly; which is what results in them remaining blank, as on line 36 you'll see:

ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")

which specifically references a sheet with the name from the myarr array, which doesn't exist. So the data is never copied.

Solution

As suggested by David Zemens on Stack Overflow; replace line 23 with:

If ws.Cells(i, vcol) <> "" And IsError(Application.Match(ws.Cells(i, vcol), ws.Columns(icol), 0)) Then

and remove line 22.

This results in the script displaying the correct error for naming issues (This one was due to the name being too long)

---

I hope this helps someone else, as this script was a godsend for the task I needed to do!