Solved

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

Posted on 2014-12-09
7
1,507 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
7 Comments
 
LVL 18

Expert Comment

by:SimonAdept
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 31

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
Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

 
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 500 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

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
Active Directory replication delay is the cause to many problems.  Here is a super easy script to force Active Directory replication to all sites with by using an elevated PowerShell command prompt, and a tool to verify your changes.
The viewer will learn how to create and use a small PHP class to apply a watermark to an image. This video shows the viewer the setup for the PHP watermark as well as important coding language. Continue to Part 2 to learn the core code used in creat…
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…

705 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

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now