Last active
March 5, 2024 15:44
-
-
Save martinctc/7e7eda2bdb536863e838630bd6927df9 to your computer and use it in GitHub Desktop.
Split data into multiple worksheet based on column variables - edited from online sources
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
@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 toApplication.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 theSheets.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!