Solved

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

Posted on 2010-09-06
7
417 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 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
Instantly Create Instructional Tutorials

Contextual Guidance at the moment of need helps your employees adopt to new software or processes instantly. Boost knowledge retention and employee engagement step-by-step with one easy solution.

 
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

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
With User Account Control (UAC) enabled in Windows 7, one needs to open an elevated Command Prompt in order to run scripts under administrative privileges. Although the elevated Command Prompt accomplishes the task, the question How to run as script…
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
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…

737 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