Split current worksheet into multiple worksheets based on values in the Column specifed by the user

Dear experts,

The following code splits the worksheet named 'DataSource' into multiple worksheets based on the values in Column A

The macro works just fine.

I would now like to change the code to accommodate the follwing requirements:

1. It should be the active worksheet on which the macro works on, not the 'DataSource'-worksheet (see line 4)
2. An input box should prompt the user to specify a column number (see line 5)
3. The newly created worksheets' columns  should have the property 'AutoFit Columns'

Help is much appreciated.

Thank you very much in advance.

I have attached a sample file for your convenience.

Regards, Andreas




Sub split_column_into_multiple_worksheets()

'Split data into multiple worksheets based on values/string in column
Const sname As String = "DataSource" 'My new requirement: It should be the active worksheet
Const s As String = "A" 'My new requirement: it should be an inputbox where the user specifies the column number
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

Open in new window



split_worksheet_into_worksheets_base.xls
Andreas HermleTeam leaderAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Bill PrewCommented:
Give this a try please.

Sub split_column_into_multiple_worksheets()

    'Split data into multiple worksheets based on values/string in column
    Dim sht As Excel.Worksheet
    Dim d As Object, a, cc&
    Dim p&, i&, rws&, cls&
    
    Set d = CreateObject("scripting.dictionary")

    s = Application.InputBox(prompt:="Specify split column letter:", Title:="Split column", Type:=2)
    If s = "" Then Exit Sub

    Set sht = ActiveSheet
    With sht
        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:=sht)
        sht.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)
                    Cells.EntireColumn.AutoFit
                End If
                p = i
            End If
        Next i
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End With

    sht.Activate

End Sub

Open in new window


»bp
0
Rgonzo1971Commented:
Hi,

pls try
Sub split_column_into_multiple_worksheets()

'Split data into multiple worksheets based on values/string in column
On Error Resume Next
Set RngS = Application.InputBox(prompt:="Select split column:", Title:="Split column", Type:=8)
On Error GoTo 0
If IsEmpty(RngS) Then Exit Sub
s = RngS.Column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    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

Open in new window

Regards
0
Andreas HermleTeam leaderAuthor Commented:
Hi Rafael,

I have had at least 100 problems solved by you quickly and professional. Thank you vey much for that once again.

Now this is the very first time that one of your solutions does (initially) not work, ie an error message pops up telling something like 'the reference is not valid ..."

I know that you could easily debug your code but since Bill's code works just fine and he was a bit quicker to answer, all the points will be awarded to him.

Thank you very much anyway for your great and professional help. I really appreciate it.

Regards, Andreas
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

Andreas HermleTeam leaderAuthor Commented:
Hi Bill,

great works like a charm, thank you very much for it.

There is a thing I would like to ask you to integrate in this code, if possible.

The user is only allowed to enter column letters A to AZ, i.e. the input box is to be restricted to these column letters.

Could you please tweak the code accordingly. Thank you very much for it.

Regards, Andreas
0
Rgonzo1971Commented:
then try
Sub split_column_into_multiple_worksheets()

'Split data into multiple worksheets based on values/string in column
Set rngS = Nothing
On Error Resume Next
Set rngS = Application.InputBox(prompt:="Select split column:", Title:="Split column", Type:=8)
On Error GoTo 0
If rngS Is Nothing Then Exit Sub
S = rngS.Column
If S > 52 Then
   MsgBox "column out of range"
    Exit Sub
End If
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    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

Open in new window

0
Andreas HermleTeam leaderAuthor Commented:
Hi Rafael,

thank you very much for your swift help.

I am afraid to tell you that I am still getting the same error regardless of what I enter in the input box ...

error message inputbox prompt
Any Idea why?

Regards, Andreas
0
Rgonzo1971Commented:
Sorry I didn't explain the Inputbox is looking for a range
pls select the column or one cell in the column
0
Andreas HermleTeam leaderAuthor Commented:
ah ok, will test that, thank you very much Rafael
0
Andreas HermleTeam leaderAuthor Commented:
Hi Rafael, it stops on line 27, apparently 'sname' is unknown.
0
Rgonzo1971Commented:
then try
Sub split_column_into_multiple_worksheets()
sname = Activesheet.Name
'Split data into multiple worksheets based on values/string in column
Set rngS = Nothing
On Error Resume Next
Set rngS = Application.InputBox(prompt:="Select split column:", Title:="Split column", Type:=8)
On Error GoTo 0
If rngS Is Nothing Then Exit Sub
S = rngS.Column
If S > 52 Then
   MsgBox "column out of range"
    Exit Sub
End If
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    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

Open in new window

0
Bill PrewCommented:
This will restrict input to A - AZ.

Sub split_column_into_multiple_worksheets()

    'Split data into multiple worksheets based on values/string in column
    Dim sht As Excel.Worksheet
    Dim d As Object, a, cc&
    Dim p&, i&, rws&, cls&
    Dim endLoop As Boolean
    
    Set d = CreateObject("scripting.dictionary")

    s = "A"
    endLoop = False
    Do While Not endLoop
        s = Application.InputBox(prompt:="Specify split column letter (A - AZ):", Title:="Split column", Default:=s, Type:=2)
        If s = "" Then Exit Sub
        s = UCase(s)
        Select Case Len(s)
            Case 1
                If s >= "A" And s <= "Z" Then
                    endLoop = True
                End If
            Case 2
                If Left(s, 1) >= "A" And Left(s, 1) <= "Z" And Right(s, 1) >= "A" And Right(s, 1) <= "Z" Then
                    endLoop = True
                End If
        End Select
    Loop

    Set sht = ActiveSheet
    With sht
        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:=sht)
        sht.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)
                    Cells.EntireColumn.AutoFit
                End If
                p = i
            End If
        Next i
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End With

    sht.Activate

End Sub

Open in new window


»bp
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Andreas HermleTeam leaderAuthor Commented:
Hi Bill, very nice loop option on the input prompt  :-)
1
Andreas HermleTeam leaderAuthor Commented:
Hi Rafael, ok, great, now your macro works as well :-).

Thank you very much for it.

Since I like Bill's input box option better and he was a bit quicker to answer I will award him the majority of the points. I hope you do not mind. :-)
0
Andreas HermleTeam leaderAuthor Commented:
Great job from both of, you really are experts in your field.

I am really happy  to have access to this wonderful forum.

Regards, Andreas
0
Bill PrewCommented:
Welcome, happy to help.


»bp
0
Andreas HermleTeam leaderAuthor Commented:
Hi Bill,

uppps, just noticed an issue with your inputbox.

If the user presses the 'Cancel'-Button, the macro does not exit, instead the inputbox keeps re-appearing. Could you please tweak the code accordingly. Hope this is feasible and does not entail too much work for you.

help is much appreciated. Thank you very much in advance. Regards,
0
Andreas HermleTeam leaderAuthor Commented:
Hi Bill, found out myself to accomodate this requirement (exit on pressing the cancel button)

I just added the following line after line 15: If s = False Then Exit Sub

This did the trick for me or do you have a better answer?
0
Bill PrewCommented:
No, that seems like a reasonable approach.


»bp
0
Andreas HermleTeam leaderAuthor Commented:
Ok great, now everything is to my liking :-)
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.