Solved

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

Posted on 2014-12-09
7
1,624 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: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 32

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
3 Use Cases for Connected Systems

Our Dev teams are like yours. They’re continually cranking out code for new features/bugs fixes, testing, deploying, testing some more, responding to production monitoring events and more. It’s complex. So, we thought you’d like to see what’s working for us.

 
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

3 Use Cases for Connected Systems

Our Dev teams are like yours. They’re continually cranking out code for new features/bugs fixes, testing, deploying, testing some more, responding to production monitoring events and more. It’s complex. So, we thought you’d like to see what’s working for us.

Question has a verified solution.

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

Suggested Solutions

Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

770 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