Solved

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

Posted on 2010-09-06
7
411 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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Approximate matching with VLOOKUP and MATCH seems to me to be a greatly under-used technique, and one which is vital for getting good performance out of large lookups. Until recently I would always have advised using an exact match for simplicity an…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

867 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