Solved

Excel Macro pt. 2

Posted on 2010-09-06
7
338 Views
Last Modified: 2012-06-21
Hi,

This question is really for matthewspatrick, as he wrote the original code to which it pertains. If anyone want's to pitch in check out the question this was related to.

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])

Thanks a ton!

Andrey
0
Comment
Question by:andreyman3d2k
  • 4
  • 3
7 Comments
 
LVL 92

Accepted Solution

by:
Patrick Matthews earned 500 total points
ID: 33615008
This seems to be working.  The exception handling on the worksheet name is probably superfluous now, but leaving it in will not harm anything.

It's an extension of the "dictionary of dictionaries" approach outlined in my article http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/A_3391-Using-the-Dictionary-Class-in-VBA.html
Sub BreakItUp()
    
    Dim dic1 As Object, dic2 As Object, dic3 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 State As String
    Dim arr2 As Variant, arr3 As Variant
    Dim Counter2 As Long, Counter3 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)
            State = arr(Counter, 2)
            PlanType = arr(Counter, 3)
            If dic1.Exists(FullName) Then
                Set dic2 = dic1.Item(FullName)
                If dic2.Exists(State) Then
                    Set dic3 = dic2.Item(State)
                    dic3.Item(PlanType) = PlanType
                Else
                    Set dic3 = CreateObject("Scripting.Dictionary")
                    dic3.CompareMode = vbTextCompare
                    dic3.Add PlanType, PlanType
                End If
            Else
                Set dic2 = CreateObject("Scripting.Dictionary")
                dic2.CompareMode = vbTextCompare
                Set dic3 = CreateObject("Scripting.Dictionary")
                dic3.CompareMode = vbTextCompare
                dic3.Add PlanType, PlanType
                dic2.Add State, dic3
                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)
                State = arr2(Counter2)
                Set dic3 = dic2.Item(State)
                arr3 = dic3.Keys
                For Counter3 = 0 To UBound(arr3)
                    PlanType = arr3(Counter3)
                    .[a1].AutoFilter 1, FullName
                    .[a1].AutoFilter 2, State
                    .[a1].AutoFilter 3, PlanType
                    With ThisWorkbook
                        Set Dest = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
                    End With
                    On Error Resume Next
                    WsName = "-" & State & "-" & PlanType
                    WsName = Left(FullName, 31 - Len(WsName)) & WsName
                    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
        Next
        .[a1].AutoFilter
        .Select
    End With
    
    Set dic1 = Nothing
    Set dic2 = Nothing
    Set dic3 = Nothing
    
    MsgBox "Done"
    
End Sub

Open in new window

0
 
LVL 6

Author Closing Comment

by:andreyman3d2k
ID: 33626748
Awesome, thanks again. I voted up your Dictionaries article. Looks interesting, wish I had a real brain instead of straw!
0
 
LVL 6

Author Comment

by:andreyman3d2k
ID: 33631055
Hi matthewspatrick,

I just noticed and issue with the code -- for some reason it is only generating one sheet per full name, but not the rest! So for example, if there is a 'Angela Smith-AR-Commercial' sheet generated, it will not make a 'Angela Smith-MO-Commercial'. That data just vanishes...

It is super-urgent! could you help?

Thanks a ton,

Andrey
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 92

Expert Comment

by:Patrick Matthews
ID: 33631783
Please post a sample file, and I will have a look.
0
 
LVL 6

Author Comment

by:andreyman3d2k
ID: 33632534
Thanks. Attached is a workbook, which contains sample data layed out the way I have it, your macro, and the sheets that result when I run you macro. As you can see there are many other name-state-plan type combinations that do not get a sheet.

Thanks again,

Andrey
EE-Example.xlsm
0
 
LVL 92

Expert Comment

by:Patrick Matthews
ID: 33633036
I was missing one puny line :)

The code below appears to be working now.

Sub BreakItUp()
    
    Dim dic1 As Object, dic2 As Object, dic3 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 State As String
    Dim arr2 As Variant, arr3 As Variant
    Dim Counter2 As Long, Counter3 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)
            State = arr(Counter, 2)
            PlanType = arr(Counter, 3)
            If dic1.Exists(FullName) Then
                Set dic2 = dic1.Item(FullName)
                If dic2.Exists(State) Then
                    Set dic3 = dic2.Item(State)
                    dic3.Item(PlanType) = PlanType
                Else
                    Set dic3 = CreateObject("Scripting.Dictionary")
                    dic3.CompareMode = vbTextCompare
                    dic3.Add PlanType, PlanType
                    dic2.Add State, dic3          'this is the line that was missing!
                End If
            Else
                Set dic2 = CreateObject("Scripting.Dictionary")
                dic2.CompareMode = vbTextCompare
                Set dic3 = CreateObject("Scripting.Dictionary")
                dic3.CompareMode = vbTextCompare
                dic3.Add PlanType, PlanType
                dic2.Add State, dic3
                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)
                State = arr2(Counter2)
                Set dic3 = dic2.Item(State)
                arr3 = dic3.Keys
                For Counter3 = 0 To UBound(arr3)
                    PlanType = arr3(Counter3)
                    .[a1].AutoFilter 1, FullName
                    .[a1].AutoFilter 2, State
                    .[a1].AutoFilter 3, PlanType
                    With ThisWorkbook
                        Set Dest = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
                    End With
                    On Error Resume Next
                    WsName = "-" & State & "-" & PlanType
                    WsName = Left(FullName, 31 - Len(WsName)) & WsName
                    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
        Next
        .[a1].AutoFilter
        .Select
    End With
    
    Set dic1 = Nothing
    Set dic2 = Nothing
    Set dic3 = Nothing
    
    MsgBox "Done"
    
End Sub

Open in new window

0
 
LVL 6

Author Comment

by:andreyman3d2k
ID: 33637161
Ah, genius! Thank you muchly.

Andrey
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

Not long ago I saw a question in the VB Script forum that I thought would not take much time. You can read that question (Question ID  (http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28455246.html)28455246) Here (http…
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
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…
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

910 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

22 Experts available now in Live!

Get 1:1 Help Now