| 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 | |
just ran this code. I was hoping it would create a new tab for each row on my table. instead it copies my entire table across to new tabs.
Hi Alasdair - have you selected a column for 'splitting' when you ran the macro? If you want one row per sheet, you'd probably need to apply this to an 'id' column (i.e. unique id per row), if that makes sense.
Hi martin. yes I did select an id column as you suggest. the macro created individual sheets for each id, and gave the sheets the id name. however it then just copied the entire table across to each sheet.
I have actually found some code elsewhere that did what I wanted. I can post that here for reference
Option Explicit
Sub Split_Excercise()
Dim wsData As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
Dim Datarng As Range, FilterRange As Range
Dim rowcount As Long
Dim FilterCol As Variant
On Error GoTo progend
'******************************************************************************************************
'your master sheet
Set wsData = ThisWorkbook.Worksheets("Live")
'Column you are filtering
FilterCol = "A"
'******************************************************************************************************
With Application
.ScreenUpdating = False: .DisplayAlerts = False
End With
'add filter sheet
Set wsFilter = ThisWorkbook.Worksheets.Add
With wsData
.Activate
'add password if needed
.Unprotect Password:=""
Set Datarng = .Range("A1").CurrentRegion
'extract values from FilterCol'to filter sheet
.Cells(1, FilterCol).Resize(Datarng.Rows.Count).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=wsFilter.Range("A1"), Unique:=True
rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
'check for blank cell in range
If FilterRange.Value <> "" Then
'add the FilterRange to criteria
wsFilter.Range("B2").Value = FilterRange.Value
'check if sheet exists
If Not Evaluate("ISREF('" & FilterRange.Value & "'!A1)") Then
'add new sheet
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = FilterRange.Value
End If
'set object variable to sheet
Set wsNames = Worksheets(FilterRange.Value)
'clear sheet
wsNames.UsedRange.Clear
'copy data
Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
CopyToRange:=wsNames.Range("A1"), Unique:=False
End If
'autofit columns
wsNames.UsedRange.Columns.AutoFit
'clear from memory
Set wsNames = Nothing
Next
.Select
End With
progend:
wsFilter.Delete
With Application
.ScreenUpdating = True: .DisplayAlerts = True
End With
If Err <> 0 Then
MsgBox (Error(Err)), vbCritical, "Error"
Err.Clear
End If
End Sub
Hi Martin, Thank you for providing this. I was curious, is there a way to split columns into different worksheets? like having a worksheet for each column instead of splitting rows into different worksheets
-Yvonne
Hi Martin, Thank you for providing this. I was curious, is there a way to split columns into different worksheets? like having a worksheet for each column instead of splitting rows into different worksheets
-Yvonne
I think you can possibly write a for loop that runs through the columns, and for each column i you would create a new Worksheet, and paste it?
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!
just ran this code. I was hoping it would create a new tab for each row on my table. instead it copies my entire table across to new tabs.