Solved

Excel 2007 Macro to break up in multiple based on criteria?

Posted on 2010-09-06
7
406 Views
Last Modified: 2012-05-10
Hi,

I would like break up the data in a spreadsheet into multiple sheets based on every unique combination of values in 2 columns.

An Example spreadsheet is attached -- which has a source sheet, and 3 example sheets.
For every unique combination of Full Name and Plan Type, a new sheet is created (called "[Full Name] - [Plan Type]") and all the data for that combination is copied over (I would like to copy over the ENTIRE ROW, as there are several other columns). If the headers copied over, that would be great as well.

Thank you very much for any help on this.

Andrey
EE-Example.xlsx
0
Comment
Question by:andreyman3d2k
  • 4
  • 3
7 Comments
 
LVL 92

Assisted Solution

by:Patrick Matthews
Patrick Matthews earned 500 total points
ID: 33612953
The following macro is working for me.  It uses a "dictionary of dictionaries" to determine the unique combos, and approach I describe in my article:

http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/A_3391-Using-the-Dictionary-Class-in-VBA.html

Patrick

Sub BreakItUp()
    
    Dim dic1 As Object, dic2 As Object
    Dim LastR As Long
    Dim arr As Variant
    Dim Source As Worksheet
    Dim Dest As Worksheet
    Dim Counter As Long
    Dim FullName As String
    Dim PlanType As String
    Dim arr2 As Variant
    Dim Counter2 As Long
    Dim rng As Range
    
    Set Source = ThisWorkbook.Worksheets("Soucre")
    With Source
        .[a1].AutoFilter
        LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
        Set rng = .Range("a1:d" & LastR)
        arr = rng.Value
        Set dic1 = CreateObject("Scripting.Dictionary")
        dic1.CompareMode = vbTextCompare
        For Counter = 2 To LastR
            FullName = arr(Counter, 1)
            PlanType = arr(Counter, 3)
            If dic1.Exists(FullName) Then
                Set dic2 = dic1.Item(FullName)
                dic2.Item(PlanType) = PlanType
            Else
                Set dic2 = CreateObject("Scripting.Dictionary")
                dic2.CompareMode = vbTextCompare
                dic2.Add PlanType, PlanType
                dic1.Add FullName, dic2
            End If
        Next
        arr = dic1.Keys
        For Counter = 0 To UBound(arr)
            FullName = arr(Counter)
            Set dic2 = dic1.Item(FullName)
            arr2 = dic2.Keys
            For Counter2 = 0 To UBound(arr2)
                PlanType = arr2(Counter2)
                .[a1].AutoFilter 1, FullName
                .[a1].AutoFilter 3, PlanType
                Set Dest = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
                Dest.Name = FullName & " - " & PlanType
                rng.SpecialCells(xlCellTypeVisible).Copy Dest.[a1]
            Next
        Next
        .[a1].AutoFilter
        .Select
    End With
    
    Set dic1 = Nothing
    Set dic2 = Nothing
    
    MsgBox "Done"
    
End Sub

Open in new window

0
 
LVL 6

Author Comment

by:andreyman3d2k
ID: 33613919
Hi matthewspatrick,

Thanks very much for the code, it is very close to what I need.

2 issues:

1. It is not copying over the entire row, only the first 4 columns. Could you make it grab the whole row?

2. Some combinations end up being longer than 31 characters -- the limit for the title of an Excel workbook, so I am getting an error. Could you make it truncate the name to the first 31 chars in the event this occurs?

Thanks a lot. The dictionary of dictionaries looks very interesting, from what I am able to understand -- although I must confess it is far beyond my VBA skills.

Andrey
0
 
LVL 92

Expert Comment

by:Patrick Matthews
ID: 33614004
Sorry, the sample data only had 4 columns, so I figured that was all you needed :)  See below for revised code.

One problem with truncating at 31 characters: you could end up with duplicate sheet names.  So, I worked up an error handler that prompts for a new worksheet name instead.


Sub BreakItUp()
    
    Dim dic1 As Object, dic2 As Object
    Dim LastR As Long, LastC As Long
    Dim arr As Variant
    Dim Source As Worksheet
    Dim Dest As Worksheet
    Dim Counter As Long
    Dim FullName As String
    Dim PlanType As String
    Dim arr2 As Variant
    Dim Counter2 As Long
    Dim rng As Range
    Dim WsName As String
    
    Set Source = ThisWorkbook.Worksheets("Soucre")
    With Source
        .[a1].AutoFilter
        LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
        LastC = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set rng = .Range("a1", .Cells(LastR, LastC))
        arr = rng.Value
        Set dic1 = CreateObject("Scripting.Dictionary")
        dic1.CompareMode = vbTextCompare
        For Counter = 2 To LastR
            FullName = arr(Counter, 1)
            PlanType = arr(Counter, 3)
            If dic1.Exists(FullName) Then
                Set dic2 = dic1.Item(FullName)
                dic2.Item(PlanType) = PlanType
            Else
                Set dic2 = CreateObject("Scripting.Dictionary")
                dic2.CompareMode = vbTextCompare
                dic2.Add PlanType, PlanType
                dic1.Add FullName, dic2
            End If
        Next
        arr = dic1.Keys
        For Counter = 0 To UBound(arr)
            FullName = arr(Counter)
            Set dic2 = dic1.Item(FullName)
            arr2 = dic2.Keys
            For Counter2 = 0 To UBound(arr2)
                PlanType = arr2(Counter2)
                .[a1].AutoFilter 1, FullName
                .[a1].AutoFilter 3, PlanType
                With ThisWorkbook
                    Set Dest = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
                End With
                On Error Resume Next
                WsName = FullName & " - " & PlanType
                Do
                    Dest.Name = WsName
                    If Err <> 0 Then
                        Err.Clear
                        WsName = InputBox("Bad worksheet name.  Please enter replacement", "Invalid Entry", WsName)
                    Else
                        Exit Do
                    End If
                Loop
                rng.SpecialCells(xlCellTypeVisible).Copy Dest.[a1]
            Next
        Next
        .[a1].AutoFilter
        .Select
    End With
    
    Set dic1 = Nothing
    Set dic2 = Nothing
    
    MsgBox "Done"
    
End Sub

Open in new window

0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 6

Author Comment

by:andreyman3d2k
ID: 33614063
Thanks! Really though it would be pretty much impossible to get duplicates in this case, with my real data. However, naming each sheet would be a real pain! Would it be possible to do the truncation instead?

Andrey
0
 
LVL 92

Accepted Solution

by:
Patrick Matthews earned 500 total points
ID: 33614247
A compromise: the code below tries to simply truncate at 31 characters, and if successful it simply truncates, but if even the truncated name is problematic, it falls to the error handler for user intervention.

Sub BreakItUp()
    
    Dim dic1 As Object, dic2 As Object
    Dim LastR As Long, LastC As Long
    Dim arr As Variant
    Dim Source As Worksheet
    Dim Dest As Worksheet
    Dim Counter As Long
    Dim FullName As String
    Dim PlanType As String
    Dim arr2 As Variant
    Dim Counter2 As Long
    Dim rng As Range
    Dim WsName As String
    
    Set Source = ThisWorkbook.Worksheets("Soucre")
    With Source
        .[a1].AutoFilter
        LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
        LastC = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set rng = .Range("a1", .Cells(LastR, LastC))
        arr = rng.Value
        Set dic1 = CreateObject("Scripting.Dictionary")
        dic1.CompareMode = vbTextCompare
        For Counter = 2 To LastR
            FullName = arr(Counter, 1)
            PlanType = arr(Counter, 3)
            If dic1.Exists(FullName) Then
                Set dic2 = dic1.Item(FullName)
                dic2.Item(PlanType) = PlanType
            Else
                Set dic2 = CreateObject("Scripting.Dictionary")
                dic2.CompareMode = vbTextCompare
                dic2.Add PlanType, PlanType
                dic1.Add FullName, dic2
            End If
        Next
        arr = dic1.Keys
        For Counter = 0 To UBound(arr)
            FullName = arr(Counter)
            Set dic2 = dic1.Item(FullName)
            arr2 = dic2.Keys
            For Counter2 = 0 To UBound(arr2)
                PlanType = arr2(Counter2)
                .[a1].AutoFilter 1, FullName
                .[a1].AutoFilter 3, PlanType
                With ThisWorkbook
                    Set Dest = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
                End With
                On Error Resume Next
                WsName = Left(FullName & " - " & PlanType, 31)
                Do
                    Dest.Name = WsName
                    If Err <> 0 Then
                        Err.Clear
                        WsName = InputBox("Bad worksheet name.  Please enter replacement", "Invalid Entry", WsName)
                    Else
                        Exit Do
                    End If
                Loop
                rng.SpecialCells(xlCellTypeVisible).Copy Dest.[a1]
            Next
        Next
        .[a1].AutoFilter
        .Select
    End With
    
    Set dic1 = Nothing
    Set dic2 = Nothing
    
    MsgBox "Done"
    
End Sub

Open in new window

0
 
LVL 6

Author Comment

by:andreyman3d2k
ID: 33614527
That's not a compromise, that's the best of both worlds! Thanks!

Listen, I just realized that I need to add a 3rd column into the mix -- The State(s) column, column B. So there will need to be a sheet for every 3-combination. Full Name, State, Plan Type.

Also, it does kick up dupes, like you said it would. Even in this case though, I cannot name them right. Could we truncate the name down to make sure that the -[state]-[Plan Type] fits? The word "commercial" is the longest plan type, and state is 2 letters, so we need to make sure that -NJ-Commercial will fit at the end, which is 14 chars)

So can it be named something equivalent to=Concatenate(left([Full Name],16),"-",[state],"-",[Plan Type])

I know these are big changes, and they depart from the original scope of the Q. I opened up a relate question. I will post link to it below.


Thanks a ton!

Andrey
0
 
LVL 6

Author Comment

by:andreyman3d2k
ID: 33614543
0

Featured Post

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

This script will sweep a range of IP addresses (class c only, 255.255.255.0) and report to a log the version of office installed. What it does: 1.)      Creates log file in the directory the script is run from (if it doesn't already exist) 2.)      Sweep…
Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…

758 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

20 Experts available now in Live!

Get 1:1 Help Now