Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

Need Excel macro to separate sheet into separate tabs based on unique values in column

Posted on 2014-12-09
7
Medium Priority
?
1,968 Views
Last Modified: 2014-12-11
Need an excel macro that will look at column D in a spreadsheet and for each unique value in D, create a new tab/sheet named for that value, and copy all rows matching that value in D to the newly created tab.

Our spreadsheet has 11 columns, and I believe there are 84 unique values in column D. I'd expect that there would be 84 tabs created, and each one would contain all rows from the main sheet that had that value in column D.
0
Comment
Question by:TWCMIL
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
7 Comments
 
LVL 18

Expert Comment

by:Simon
ID: 40490131
Hi, Please see this code and/or sample workbook.

You'd need to manually create a pivot table first, with your column D as the row titles and any other column in the data area.

EE-PivotToWorksheets.xlsm
Sub PivotTable_GenerateWkShtPerLine()
Const msgTitle As String = "Pivot table burster"
Dim continue As Variant
Dim pivotSht As Worksheet

Dim pt As String
Dim titlesRange As Range
Dim shtTitlesRange As Range
Dim titlePrefix As String
Dim titleSuffix As String
Dim shtName As String
Dim fitToOnePageWide_999Tall As Boolean

continue = MsgBox("This creates one sheet for each selected row in the pivot table, named according to the column(s) you choose." & vbCrLf & "For best results, ensure you have sorted the base data and set the default table style before running this.", vbOKCancel + vbInformation, msgTitle)
If continue <> vbOK Then Exit Sub Else

Set pivotSht = ActiveSheet
'Test whether the selection is part of a pivot table.
On Error Resume Next
pt = ActiveSheet.Range(Selection.Address).PivotTable.Name
If Err.Number <> 0 Then
    MsgBox "The selected range (" & Selection.Address & ") is not part of a pivot table!", , msgTitle
    Exit Sub
End If
On Error GoTo 0

If Selection.Cells.Count < 2 Then
    If MsgBox("Select a range of cells (usually the totals) for which to show details (by generating a new sheet per pivot row)", vbOKCancel, msgTitle) <> vbOK Then
        Exit Sub
    End If
End If

'Prompt user to select the columns from which to generate sheet names
On Error Resume Next
Set titlesRange = Application.InputBox("Which columns have the data that will form the worksheet names?", msgTitle, , , , , , 8)
If Err.Number <> 0 Then Exit Sub Else
On Error GoTo 0
Debug.Print "Titles from range: " & titlesRange.Address

On Error Resume Next
titlePrefix = Application.InputBox("Add a prefix to the worksheet names if desired", msgTitle, , , , , , 2)
If Err.Number <> 0 Then Exit Sub Else
On Error GoTo 0
Debug.Print "Title prefix string: " & titlePrefix

On Error Resume Next
titleSuffix = Application.InputBox("Add a suffix to the worksheet names if desired", msgTitle, , , , , , 2)
If Err.Number <> 0 Then Exit Sub Else
On Error GoTo 0
Debug.Print "Title suffix string: " & titleSuffix

'
'If MsgBox("Fit result sheets to one landscape page wide?", vbQuestion + vbYesNo, msgTitle) = vbYes Then
'fitToOnePageWide_999Tall = True
'End If


'*** Main Loop ***
Dim c As Variant
Dim i As Variant
For Each c In Selection
    Debug.Print Intersect(titlesRange, Rows(c.Row)).Address
    Set shtTitlesRange = Intersect(titlesRange, Rows(c.Row))
    shtName = ""
    For Each i In shtTitlesRange
        If shtName = "" Then
            shtName = i
        Else
            shtName = shtName & "_" & i
        End If
    Next
    shtName = titlePrefix & shtName & titleSuffix
    shtName = Left(shtName, 31)
    c.ShowDetail = True 'This creates a new worksheet for the pivot table item's detail lines
    ActiveSheet.Name = shtName
    
    
    If fitToOnePageWide_999Tall Then
        Call PageSetup_FitToOnePageWideBy999Tall
    End If
    ActiveSheet.Cells(2, 1).Select
    'Turn off autofilter to make sheet autofit columns more tightly
    Selection.AutoFilter 'This relies on the fact that the result sheet are initially autofiltered (so this command turns the filter OFF)
    ActiveSheet.Columns.AutoFit
    ActiveWindow.FreezePanes = True
    ActiveSheet.Cells(1, 1).Select 'Leave sheet with cell A1 selected
    'switch focus back to pivot sheet, so that intersect statement works.
    pivotSht.Activate
Next
End Sub

Open in new window

0
 
LVL 10

Expert Comment

by:bromy2004
ID: 40490583
Without Pivot Tables

Change A1:A14 to the Unique Variable Range

Option Explicit

Sub Test()
Dim c As Range
Dim r As Range

Dim wb As Workbook
Dim ws As Worksheet

Dim arr() As String

Set wb = ActiveWorkbook
Set r = wb.Sheets("Sheet1").Range("A1:A14")

ReDim arr(0 To 0)

'Get Unique Values and new sheets
For Each c In r
    If Not CheckArray(c.Value, arr) Then
        arr(UBound(arr)) = c.Value
        ReDim Preserve arr(LBound(arr) To UBound(arr) + 1)
        
        Set ws = wb.Sheets.Add
        ws.Name = c.Value
    End If
    
    c.EntireRow.Copy
    ws.Paste ws.Range("A1").SpecialCells(xlLastCell).Offset(1, 0)
    
    
Next c


End Sub

Function CheckArray(Value As String, MyArray() As String) As Boolean

Dim i As Integer

For i = LBound(MyArray) To UBound(MyArray)
    If MyArray(i) = Value Then
        CheckArray = True
        Exit Function
    End If
Next i

CheckArray = False
End Function

Open in new window

0
 
LVL 33

Expert Comment

by:Rob Henson
ID: 40490960
You can also do this with Advanced Filter (AF), choosing the Copy To another location option.

AF can be automated into VBA.

Thanks
Rob H
0
Quick Start: DOCKER

Sometimes you just need a Quick Start on a topic in order to begin using it.. this is just what you need to know to get up and running with Docker!

 
LVL 1

Author Comment

by:TWCMIL
ID: 40492773
bromy2004,

Yours looks like what I was looking for, however when I update the range to include the column with the unique values (in my case, it's D2:D1548) and run it I get an error "subscript out of range".

I've uploaded an example spreadsheet that has the same column headings with sample data in it. My spreadsheet would be similar, but with 1548 rows.

Let me know if there is anything else I need to change to make your script work.

Thanks,

TWCMIL
J--example.xlsx
0
 
LVL 10

Accepted Solution

by:
bromy2004 earned 2000 total points
ID: 40493056
Update:
Modify the Constants at the top for the maste sheet (With the Range including Row 2 (Ignore header) to the last value)
It still accounts for blank cells though.

Not sure how you got an Out of Range error.

The only way I can guess would be your "Last Cell" is A65536 (or 1.2 million, whatever the lowest cell is)
It would fail then because the Row beneath that (that its trying to paste in) doesn't exist.


Sub Test()

Const MASTER_SHEET_NAME = "Sheet1"
Const MASTER_SHEET_RANGE = "A2:A14"

Dim c As Range
Dim r As Range

Dim wb As Workbook
Dim ws As Worksheet

Dim arr() As String

Set wb = ActiveWorkbook
Set r = wb.Sheets(MASTER_SHEET_NAME).Range(MASTER_SHEET_RANGE)

ReDim arr(0 To 0)

'Get Unique Values and new sheets
For Each c In r
    If Not c.Value = "" Then
        If Not CheckArray(c.Value, arr) Then
            arr(UBound(arr)) = c.Value
            ReDim Preserve arr(LBound(arr) To UBound(arr) + 1)
            
            Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            ws.Name = c.Value
        End If
        
        r.Worksheet.Range("A1").EntireRow.Copy
        ws.Paste ws.Range("A1").EntireRow
        
        c.EntireRow.Copy
        ws.Paste ws.Range("A1").SpecialCells(xlLastCell).Offset(1, 0).EntireRow
        
    End If
Next c

Application.CutCopyMode = False

End Sub

Function CheckArray(Value As String, MyArray() As String) As Boolean

Dim i As Integer

For i = LBound(MyArray) To UBound(MyArray)
    If MyArray(i) = Value Then
        CheckArray = True
        Exit Function
    End If
Next i

CheckArray = False
End Function

Open in new window

0
 
LVL 1

Author Comment

by:TWCMIL
ID: 40495280
I believe I've figured out the problem. The values in my column D were too big to be worksheet names. When I went through and shortened them up, it worked. Thanks for everyone for your help!
0
 
LVL 1

Author Closing Comment

by:TWCMIL
ID: 40495285
This does what I need. Thank you!
0

Featured Post

On Demand Webinar: Networking for the Cloud Era

Ready to improve network connectivity? Watch this webinar to learn how SD-WANs and a one-click instant connect tool can boost provisions, deployment, and management of your cloud connection.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
: Microsoft Office Collaborate for free and online versions of Microsoft  Word, Excel, Powerpoint, OneNote, Onedrive , Email, Calendar etc. In short we can say that Microsoft office is a suite of servers, applications and services developed by  Micr…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
In this seventh video of the Xpdf series, we discuss and demonstrate the PDFfonts utility, which lists all the fonts used in a PDF file. It does this via a command line interface, making it suitable for use in programs, scripts, batch files — any pl…

688 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question