Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
?
Solved

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

Posted on 2010-09-06
7
Medium Priority
?
423 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 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
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
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

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering 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

How to get Spreadsheet Compare 2016 working with the 64 bit version of Office 2016
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…
Enter Foreign and Special Characters Enter characters you can't find on a keyboard using its ASCII code ... and learn how to make a handy reference for yourself using Excel ~ Use these codes in any Windows application! ... whether it is a Micr…

577 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