?
Solved

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

Posted on 2010-09-06
7
Medium Priority
?
419 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
[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
  • 4
  • 3
7 Comments
 
LVL 93

Assisted Solution

by:Patrick Matthews
Patrick Matthews earned 2000 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 93

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
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
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 93

Accepted Solution

by:
Patrick Matthews earned 2000 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

Featured Post

Want to be a Web Developer? Get Certified Today!

Enroll in the Certified Web Development Professional course package to learn HTML, Javascript, and PHP. Build a solid foundation to work toward your dream job!

Question has a verified solution.

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

This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
If you need to forecast numbers -- typically for finance -- the Windows and Mac versions of Excel 2016 have a basket of tools to get the job done.
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

771 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