VBA: Split data into multiple worksheets based on column

mirabeau

Banned user
Joined
Nov 4, 2010
Messages
2,075
Hi mirabeau,

Sorry, I meant to say the produced sheet names are in reverse alphabetical order.
...
I don't quite follow you there.
That code was designed to produce sheets in normal alphabetical order and has always done so for me.

However, just to try something, in the line

.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes

if you change the 2 to 1, does it make any difference to the order of your produced sheets?
 

Some videos you may like

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

bigtex86

New Member
Joined
Mar 15, 2014
Messages
20
Really depends on the data and the problem.
You could try this one and see if it works for you
Code:
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
This seems to be REALLY close to what I need. I need help with a couple of tweaks though. I need rows 1:10 to stay the same and be copied to every sheet. And is there any way to keep the column widths and formatting the same in all sheets? Thanks for the help!
 

johncameronreid

New Member
Joined
Oct 1, 2014
Messages
1
Hi! What a great macro! It works perfectly for me; except, when the data is parsed out, no parsing is occurring. That is, the macro creates all of the new worksheets and gives the worksheets the appropriate name (values I have in column "A"). However, the entire data set is being copied to each worksheet. Any help is appreciated.

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.

Code:
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!
 

fjlaff

New Member
Joined
Mar 10, 2014
Messages
3
Hi! What a great macro! It works perfectly for me; except, when the data is parsed out, no parsing is occurring. That is, the macro creates all of the new worksheets and gives the worksheets the appropriate name (values I have in column "A"). However, the entire data set is being copied to each worksheet. Any help is appreciated.

If I recall correctly, this is where you need the sorting of column A, then for it to copy identical values to the corresponding sheet, until it hits a new value. I will try and have a look for my macro, not sure where it is now.
 

joeyc123

New Member
Joined
Nov 5, 2014
Messages
9
Hi mirabeau,

I'm trying to get the code below in this thread to work but i am getting a debug error below in red, please help.

Code:
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 = 3
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:G1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
[COLOR=#ff0000]For i = 7 To lr[/COLOR]
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
 
Last edited by a moderator:

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
34,692
Office Version
365, 2019, 2016, 2010
Platform
Windows, MacOS
What's the error? (you should really declare i as Long, not Integer)
 

joeyc123

New Member
Joined
Nov 5, 2014
Messages
9
What's the error? (you should really declare i as Long, not Integer)
thanks for the replr rory, When i hit debug this line is highlighted "For i = 7 To lr how do i change it?
 

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
34,692
Office Version
365, 2019, 2016, 2010
Platform
Windows, MacOS
What is the error message?
 

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
34,692
Office Version
365, 2019, 2016, 2010
Platform
Windows, MacOS
Like I said, you need to declare i as Long, not Integer. ;)
 

Watch MrExcel Video

Forum statistics

Threads
1,090,046
Messages
5,412,036
Members
403,409
Latest member
IHRAcer

This Week's Hot Topics

Top