Adding Stuff to the Top of a Dictionary

Posted on November 9, 2016 by Dick Kusleika

I wrote a KwikOpen addin that I use about a million times a day. I ran into a little nagging problem. When I Save As’d a file from the addin, it never showed up on the recently opened list. I finally decided to track down the bug. A while back, I switched my custom class storage method from Collection to Dictionary. I don’t remember why, but I’m sure it was a fine reason. I ended up with this Add method

Public Sub Add(clsRcntFile As CRcntFile, Optional ByVal bToTop As Boolean = False)
'    If clsRcntFile.RcntFileID = 0 Then
'        clsRcntFile.RcntFileID = Me.Count + 1
'    End If

    If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then
        mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile
    End If

    'Set clsRcntFile.Parent = Me
'    If bToTop Then
'
'        mcolRcntFiles.Add clsRcntFile, CStr(clsRcntFile.RcntFileID), 1
'    Else
'        mcolRcntFiles.Add clsRcntFile, CStr(clsRcntFile.RcntFileID)
'    End If
'
End Sub

Public Sub Add(clsRcntFile As CRcntFile, Optional ByVal bToTop As Boolean = False)

' If clsRcntFile.RcntFileID = 0 Then

' clsRcntFile.RcntFileID = Me.Count + 1

' End If

If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then

mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile

End If

'Set clsRcntFile.Parent = Me

' If bToTop Then

' mcolRcntFiles.Add clsRcntFile, CStr(clsRcntFile.RcntFileID), 1

' Else

' mcolRcntFiles.Add clsRcntFile, CStr(clsRcntFile.RcntFileID)

' End If

End Sub

I have this optional argument, bToTop, so I can add it to the front of the list. But as you can see from the commented code at the bottom, that argument is basically ignored. Dictionaries don’t allow you to insert values into specific locations and that code no longer works.

So why a bug? Because I only store the most recent 2,000 files, and I’m at that limit, any Save As’d file would become 2,001 and not written to disk. When I’d go to open a file, it would read in from the file again and, of course, that recently saved file was not there.

Surely there’s a quick and easy method for pushing something to the top. Nope. All I could find was rewriting the whole Dictionary.

Public Sub Add(clsRcntFile As CRcntFile, Optional ByVal bToTop As Boolean = False)

    Dim dcTemp As Scripting.Dictionary
    Dim i As Long

    If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then
        If bToTop Then
            Set dcTemp = New Scripting.Dictionary
            dcTemp.Add clsRcntFile.FullName, clsRcntFile
            For i = 0 To mdcRcntFiles.Count - 1
                dcTemp.Add mdcRcntFiles.Keys(i), mdcRcntFiles.Items(i)
            Next i
            Set mdcRcntFiles = dcTemp
        Else
            mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile
        End If
    End If

End Sub

Public Sub Add(clsRcntFile As CRcntFile, Optional ByVal bToTop As Boolean = False)

Dim dcTemp As Scripting.Dictionary

Dim i As Long

If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then

If bToTop Then

Set dcTemp = New Scripting.Dictionary

dcTemp.Add clsRcntFile.FullName, clsRcntFile

For i = 0 To mdcRcntFiles.Count - 1

dcTemp.Add mdcRcntFiles.Keys(i), mdcRcntFiles.Items(i)

Next i

Set mdcRcntFiles = dcTemp

Else

mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile

End If

End Sub

In that code, I create a temporary Dictionary, dcTemp, put my Save As’d file in first, then fill in the rest, finally replacing the old Dictionary with the temporary one. That’s not exactly elegant, but it gets the job done. I tested it and found that the recently saved file was not on the top of the list. It was near the top, but I inserted it first, it should be at the top. Then I remembered that I read in Excel’s MRU before I read in my file. That means there are 50 files ahead of the one I just saved. No biggie, but it gave me an idea.

Instead of recreating the Dictionary, why don’t I just add it to the MRU? There are some websites about adding entries to the registry but that won’t work. Excel reads the registry when it opens and I wasn’t about to close and reopen the app. Another way to add a file to the MRU are to specify the arguments in the Open and SaveAs methods. I am saving a file. Now my Add method looks like this

Public Sub Add(clsRcntFile As CRcntFile)
        
    If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then
        mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile
    End If
    
End Sub

Public Sub Add(clsRcntFile As CRcntFile)

If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then

mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile

End If

End Sub

The heavy lifting is done when I save the file

    Dim fd As FileDialog
    Dim clsRcntFile As CRcntFile
    Dim clsError As CError
    
    If Not gbDebug Then On Error GoTo ErrHandler
    Set clsError = New CError: clsError.SetLoc "USaveAs", "cmdOpen_Click"
    
    Set fd = Application.FileDialog(msoFileDialogSaveAs)
    
    fd.InitialFileName = Me.lbxPlaces.Value & ActiveWorkbook.Name
    
    Select Case ActiveWorkbook.FileFormat
        Case 50: fd.FilterIndex = 3
        Case 52: fd.FilterIndex = 2
        Case 56: fd.FilterIndex = 4
        Case Else: fd.FilterIndex = 1
    End Select
        
    fd.Show
    'fd.Execute
    
    If fd.SelectedItems.Count > 0 Then
        Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs fd.SelectedItems(1), , , , , , , , True
        Application.DisplayAlerts = True
'        Set clsRcntFile = New CRcntFile
'        clsRcntFile.FullName = fd.SelectedItems(1)
'        Me.RcntFiles.Add clsRcntFile, True
    End If

Dim fd As FileDialog

Dim clsRcntFile As CRcntFile

Dim clsError As CError

If Not gbDebug Then On Error GoTo ErrHandler

Set clsError = New CError: clsError.SetLoc "USaveAs", "cmdOpen_Click"

Set fd = Application.FileDialog(msoFileDialogSaveAs)

fd.InitialFileName = Me.lbxPlaces.Value & ActiveWorkbook.Name

Select Case ActiveWorkbook.FileFormat

Case 50: fd.FilterIndex = 3

Case 52: fd.FilterIndex = 2

Case 56: fd.FilterIndex = 4

Case Else: fd.FilterIndex = 1

End Select

fd.Show

'fd.Execute

If fd.SelectedItems.Count > 0 Then

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs fd.SelectedItems(1), , , , , , , , True

Application.DisplayAlerts = True

' Set clsRcntFile = New CRcntFile

' clsRcntFile.FullName = fd.SelectedItems(1)

' Me.RcntFiles.Add clsRcntFile, True

End If

That lone True out there is the AddToMru argument. By getting rid of the .Execute method and doing the SaveAs myself, I also got rid of a problem where overwriting an existing file caused two warning prompts. Now there’s no need for me to add it to my list (the commented out code at the bottom) because Excel adds it to its list and that’s what I read first.

Storing Stuff in VBA Lists

Posted on October 5, 2016 by Dick Kusleika

You no doubt recall when snb wrote about Scripting.Dictionaires. Well, there’s more.

I use Collection objects in my custom class modules almost exclusively. It’s the only object, that I know of, that I can enumerate using For Each.

Outside of custom class modules, I use Dictionary objects. I used to avoid them because they weren’t built in to the language. I was always afraid of some dependency problem. But I’ve never seen one in all my years, so I’m over that now. The advantage of the Exists property and the ability to produce an array of keys or items is awesome. it’s probably more awesome than For Each, but I just haven’t made that leap yet.

And I never use ArrayLists because I never remember them. That’s not totally true. When I’m writing a procedure with a Dictionary and I need to sort, I kick myself for not using an ArrayList.

Here’s some features of Collections, Dictionaries, and ArrayLists.

Feature	Collection	Dictionary	ArrayList
New Enum in class	Yes	No	No
Exists	No	.Exists	.Contains
Key Value paradigm	Yes	Yes	No
Unique keys	Yes	Yes	NA
Key data types	String	Any	NA
Get keys	No	Yes	NA
Auto create items	No	Yes	No
Insert anywhere	.Add(,,before,after)	No	.Insert
Output to array	No	.Keys or .Items	.ToArray

There are other differences. Those are just the ones that are important to me. If there’s a difference that’s important to you, leave a comment. You can read everything you ever wanted to know about these objects at one of the pages below:

Collections: http://www.snb-vba.eu/VBA_Collection_en.html
Dictionaries: http://www.snb-vba.eu/VBA_Dictionary_en.html
ArrayLists: http://www.snb-vba.eu/VBA_Arraylist_en.html

Fun with Excel; A Wheel Of Fortune

Posted on September 29, 2016 by jkpieterse

Hi everyone,

Long time no see!

It seems the busier one is, the more work gets done. I’ve published a nice article today, in which I explain how I created a Wheel Of Fortune made entirely in Excel some years ago. This is what it looks like:

Enjoy!

Jan Karel Pieterse

www.jkp-ads.com

Deleting Pivot Table Drilldown Sheets

Posted on September 9, 2016 by Dick Kusleika

I tried to make drilling into pivot tables better once upon a time. I failed. Earlier this week, I read Debra’s blog post about showing details and deleting the sheets later. It got me thinking.

The problem I have is that her solution (and many others) rely on the Before_DoubleClick event. As you might imagine, I don’t double click to show pivot table details. I press the context menu key and choose Show Details from the menu. I need a different event or to capture that context menu item. I don’t think there’s any event that will allow me to identify new sheets only when they come from showing details of a pivot table. It doesn’t matter. The better answer is create my own shortcut.

In my Auto_Open and Auto_Close procedures in my PMW:

Application.OnKey "^+d", "PTDrillDown"

Application.OnKey "^+d"

Application.OnKey "^+d", "PTDrillDown"

Application.OnKey "^+d"

That’s Ctrl+Shift+D for the uninitiated. That will now run PTDrillDown

Public Sub PTDrillDown()
    
    Dim pt As PivotTable
        
    On Error Resume Next
        Set pt = ActiveCell.PivotTable
    On Error GoTo 0
    
    If Not pt Is Nothing Then
        If Not Intersect(ActiveCell, pt.DataBodyRange) Is Nothing Then
            ActiveCell.ShowDetail = True
        
            On Error Resume Next
                Application.DisplayAlerts = False
                    ActiveWorkbook.Sheets(gsDRILLSHEET).Delete
                Application.DisplayAlerts = True
            On Error GoTo 0
            ActiveSheet.Name = gsDRILLSHEET
        End If
    End If
    
End Sub

Public Sub PTDrillDown()

Dim pt As PivotTable

On Error Resume Next

Set pt = ActiveCell.PivotTable

On Error GoTo 0

If Not pt Is Nothing Then

If Not Intersect(ActiveCell, pt.DataBodyRange) Is Nothing Then

ActiveCell.ShowDetail = True

On Error Resume Next

Application.DisplayAlerts = False

ActiveWorkbook.Sheets(gsDRILLSHEET).Delete

Application.DisplayAlerts = True

On Error GoTo 0

ActiveSheet.Name = gsDRILLSHEET

End If

End Sub

Lot’s of

On Error's

1	On Error's

in there. That’s the sign of really tight code, you know. This determines if the ActiveCell is in a pivot table by trying to set a PivotTable variable. If it’s in a pivot table, it next checks to see if it’s in the body (as opposed to row or column headers or filters). If it’s in the body, the code shows the detail, deletes any sheet with my special name, and names the resulting sheet with my special name. The special name lives in my MGlobals module.

Public Const gsDRILLSHEET As String = "_PivotDrill"

1	Public Const gsDRILLSHEET As String = "_PivotDrill"

And for the coup de grace, I have a class module that defines an Application variable WithEvents. I added this event procedure to it.

Private Sub mxlApp_SheetDeactivate(ByVal Sh As Object)
    
    If Sh.Name = gsDRILLSHEET Then
        Application.DisplayAlerts = False
            Sh.Delete
        Application.DisplayAlerts = True
    End If
    
End Sub

Private Sub mxlApp_SheetDeactivate(ByVal Sh As Object)

If Sh.Name = gsDRILLSHEET Then

Application.DisplayAlerts = False

Sh.Delete

Application.DisplayAlerts = True

End If

End Sub

Whenever I switch off of the details sheet, it goes away. Now that’s keeping things tidy.

KwikOpen Update

Posted on August 31, 2016 by Dick Kusleika

A year and a half ago, I decided that I was going to make a change to my KwikOpen add-in to get rid of recent files that no longer exist. Well, I finally got it done. No, it didn’t take that long to implement. The performance of the add-in has been fine so there wasn’t a pressing need. The other day, the addin seemed a little less peppy than usual and I thought it was time for a look.

I had 2,368 files in my MRU and 465 of them are dead links. That’s about 20% and it’s similar to the proportion I saw back in February 2015. Of the three options I listed at the bottom of my previous post, I chose none of them. Instead, I weeded out some files as I wrote them back out to disk.

Public Sub WriteToDisk()
    
    Dim sFile As String
    Dim lFile As Long
    Dim clsRcntFile As CRcntFile
    Dim aFiles(1 To 3000) As String
    Dim lFileCnt As Long
    Dim lWriteCnt As Long
        
    Const dWEEDLIMIT As Double = 0.9
    
    For Each clsRcntFile In Me
        lFileCnt = lFileCnt + 1
        If lFileCnt < Me.Count * dWEEDLIMIT Or clsRcntFile.Exists Then
            lWriteCnt = lWriteCnt + 1
            aFiles(lWriteCnt) = clsRcntFile.FullName
        End If
        If lWriteCnt >= UBound(aFiles) Then Exit For
    Next clsRcntFile
    
    sFile = Environ$("APPDATA") & "\Microsoft\Addins\" & msMRUFILE
    lFile = FreeFile
    
    Open sFile For Output As lFile
    Print #lFile, Join(aFiles, vbNewLine)
    Close lFile
    
End Sub

Public Sub WriteToDisk()

Dim sFile As String

Dim lFile As Long

Dim clsRcntFile As CRcntFile

Dim aFiles(1 To 3000) As String

Dim lFileCnt As Long

Dim lWriteCnt As Long

Const dWEEDLIMIT As Double = 0.9

For Each clsRcntFile In Me

lFileCnt = lFileCnt + 1

If lFileCnt < Me.Count * dWEEDLIMIT Or clsRcntFile.Exists Then

lWriteCnt = lWriteCnt + 1

aFiles(lWriteCnt) = clsRcntFile.FullName

End If

If lWriteCnt >= UBound(aFiles) Then Exit For

Next clsRcntFile

sFile = Environ$("APPDATA") & "\Microsoft\Addins\" & msMRUFILE

lFile = FreeFile

Open sFile For Output As lFile

Print #lFile, Join(aFiles, vbNewLine)

Close lFile

End Sub

The file names are written to the file with the most recent at the top – sort of. Because I’m using the built-in MRU as well as my own, it’s not exactly that way, but it’s close enough for government work. Instead of time stamping the entries, I decided to dump any nonexistent files that were near the bottom of the list. If a file is in the top 90% of the list, it stays regardless of whether it exists. If it’s in the bottom 10%, it only stays if it’s still where it was.

Iteration	Total Files	Orphaned Files
Beg.	2,368	465
1	2,250	345
2	2,226	321
3	2,225	320

Looking at the last 100 or so files, they’re mostly from 2014. I could cap this at 2,000 and probably not notice.

Unique Entries in Userform Dependent Listboxes

Posted on July 27, 2016August 1, 2016 by Dick Kusleika

Deepthi commented

…could you please help me tweak the code so that I can make multiple selections in listbox 1 in such a way that the values selected in list box two has all the values applicable for the selections made (listbox) but removes all duplicates?

First, a word about that post. I have used the relationship listbox template exactly zero times. I simply prefer to build my classes from scratch with names that reflect the business objects they represent. But I did reuse the userform and I didn’t change the control names from Parent/Child to Class/Student. I’m conflicted about that, but I’ll get over it.

Let’s say we have some classes and students. A class can have many students and a student can have many classes.

When you select a class, the userform lists the students. If you select more than one class, the userform lists all the student from the selected classes, but each student is listed only once.

Andrew and Payton are only listed once.

There are some significant changes to the code, not the least of which is removing the grandchildren. Also instead of tracking ActiveParent (singular), I now track ActiveClasses (plural) because my top listbox is now multiselect. When my Parent listbox changes, I have to see all the classes that are selected.

Private Sub lbxParents_Change()

    Dim clsClass As CClass
    Dim i As Long

    If Me.lbxParents.ListIndex &lt;&gt; -1 Then
        Set Me.ActiveClasses = New CClasses
        For i = 0 To Me.lbxParents.ListCount - 1
            If Me.lbxParents.Selected(i) Then
                Me.ActiveClasses.Add Me.Classes.ClassByClassName(Me.lbxParents.List(i))
            End If
        Next i
    Else
        Set Me.ActiveClasses = Nothing
    End If

    FillChildren

End Sub

Private Sub FillChildren()

    Me.lbxChildren.Clear

    If Not Me.ActiveClasses Is Nothing Then
        If Me.ActiveClasses.StudentCount &gt; 0 Then
            Me.lbxChildren.List = Me.ActiveClasses.StudentList
            Me.lbxChildren.ListIndex = 0
        End If
    End If


End Sub

Private Sub lbxParents_Change()

Dim clsClass As CClass

Dim i As Long

If Me.lbxParents.ListIndex <> -1 Then

Set Me.ActiveClasses = New CClasses

For i = 0 To Me.lbxParents.ListCount - 1

If Me.lbxParents.Selected(i) Then

Me.ActiveClasses.Add Me.Classes.ClassByClassName(Me.lbxParents.List(i))

End If

Next i

Else

Set Me.ActiveClasses = Nothing

End If

FillChildren

End Sub

Private Sub FillChildren()

Me.lbxChildren.Clear

If Not Me.ActiveClasses Is Nothing Then

If Me.ActiveClasses.StudentCount > 0 Then

Me.lbxChildren.List = Me.ActiveClasses.StudentList

Me.lbxChildren.ListIndex = 0

End If

End Sub

To get a unique student list, I use a dictionary object. My favorite thing about dictionaries is returning a zero-based array from the Keys or Items properties.

Public Property Get StudentList() As Variant

    Dim clsClass As CClass
    Dim clsStudent As CStudent
    Dim dcReturn As Scripting.Dictionary

    Set dcReturn = New Scripting.Dictionary
    
    For Each clsClass In Me
        For Each clsStudent In clsClass.Students
            If Not dcReturn.Exists(clsStudent.StudentName) Then
                dcReturn.Add clsStudent.StudentName, clsStudent.StudentName
            End If
        Next clsStudent
    Next clsClass
    
    StudentList = dcReturn.Keys
    
End Property

Public Property Get StudentList() As Variant

Dim clsClass As CClass

Dim clsStudent As CStudent

Dim dcReturn As Scripting.Dictionary

Set dcReturn = New Scripting.Dictionary

For Each clsClass In Me

For Each clsStudent In clsClass.Students

If Not dcReturn.Exists(clsStudent.StudentName) Then

dcReturn.Add clsStudent.StudentName, clsStudent.StudentName

End If

Next clsStudent

Next clsClass

StudentList = dcReturn.Keys

End Property

You can check out the rest of the code in the downloadable file.

You can download ParentChildUserformMulti.zip

Cleaning Up My JoinRange Arguments

Posted on June 22, 2016 by Dick Kusleika

I’m trying to make my JoinRange function better and I’m failing miserably. A few years ago I added a “macro” argument because I was making so many HTML and Trac tables. I don’t use Trac anymore and I almost never make HTML tables (because I blog so infrequently, I guess). I got rid of that argument. The reason I join ranges most often is to create a big

In

clause in SQL. Let’s say I have this list of customer IDs and I want to make an

In

clause.

142

146

175

214

217

I’d use JoinRange like

=JoinRange(A2:A7,,"','","('","')")

1	=JoinRange(A2:A7,,"','","('","')")

That’s a freakin’ mess. The second argument is the now-defunct macro argument and is blank. The rest of the arguments are

3rd (delimeter): single quote, comma, single quote
4th (beginning): open paren, single quote
5th (ending): single quote, close paren

and I’d get

('38','142','146','175','214','217')

1	('38','142','146','175','214','217')

which I could paste into my SQL statement and roll. I hate typing those arguments. Worse, I hate reading those arguments. It’s pretty hard to read in this blog, but it’s worse in Excel’s formula bar. I thought if I could get rid of the single quotes, it would be cleaner. I rewrote the code to add a Quote argument that would wrap every entry in whatever quotes I supplied.

Public Function JoinRange(rInput As Range, _
    Optional sDelim As String = vbNullString, _
    Optional sLineStart As String = vbNullString, _
    Optional sLineEnd As String = vbNullString, _
    Optional sBlank As String = vbNullString, _
    Optional sQuotes As String = vbNullString) As String
    
    Dim vaCells As Variant
    Dim i As Long, j As Long
    Dim lCnt As Long
    Dim aReturn() As String
    
    vaCells = rInput.Value
    ReDim aReturn(1 To rInput.Cells.Count)
    
    For i = LBound(vaCells, 1) To UBound(vaCells, 1)
        For j = LBound(vaCells, 2) To UBound(vaCells, 2)
            lCnt = lCnt + 1
            If Len(vaCells(i, j)) = 0 Then
                aReturn(lCnt) = sQuotes & sBlank & sQuotes
            Else
                aReturn(lCnt) = sQuotes & vaCells(i, j) & sQuotes
            End If
        Next j
    Next i
    
    JoinRange = sLineStart & Join(aReturn, sDelim) & sLineEnd
    
End Function

Public Function JoinRange(rInput As Range, _

Optional sDelim As String = vbNullString, _

Optional sLineStart As String = vbNullString, _

Optional sLineEnd As String = vbNullString, _

Optional sBlank As String = vbNullString, _

Optional sQuotes As String = vbNullString) As String

Dim vaCells As Variant

Dim i As Long, j As Long

Dim lCnt As Long

Dim aReturn() As String

vaCells = rInput.Value

ReDim aReturn(1 To rInput.Cells.Count)

For i = LBound(vaCells, 1) To UBound(vaCells, 1)

For j = LBound(vaCells, 2) To UBound(vaCells, 2)

lCnt = lCnt + 1

If Len(vaCells(i, j)) = 0 Then

aReturn(lCnt) = sQuotes & sBlank & sQuotes

Else

aReturn(lCnt) = sQuotes & vaCells(i, j) & sQuotes

End If

Next j

Next i

JoinRange = sLineStart & Join(aReturn, sDelim) & sLineEnd

End Function

Now, my formula looks like this:

=JoinRange(A2:A7,",","(",")",,"'")

1	=JoinRange(A2:A7,",","(",")",,"'")

I think we can all agree that this is no better than what I had before. I thought the quotes were the problem, but it’s also that I use a comma as the delimiter and it’s the thing that separates the arguments. If I change it to pipe delimited…

=JoinRange(A2:A7,"|","(",")",,"'")

1	=JoinRange(A2:A7,"\|","(",")",,"'")

Nope. It’s still a headache to read. Based on the number of comments to this post, I’m pretty sure none of you are using predefined names in your book.xlt file. But I do. And If I’m using a workbook that I created, I could use

=JoinRange(A2:A7,xlCOMMA,"(",")",xlSINGLE)

1	=JoinRange(A2:A7,xlCOMMA,"(",")",xlSINGLE)

That’s definitely more readable to me. I guess I need a macro to add those names to any books automatically so I can use them.

Public Sub AddConstantNames()
    
    ActiveWorkbook.Names.Add "xlCOMMA", "="","""
    ActiveWorkbook.Names.Add "xlSPACE", "="" """
    ActiveWorkbook.Names.Add "xlDOUBLE", "="""""
    ActiveWorkbook.Names.Add "xlSINGLE", "=""'"""
    ActiveWorkbook.Names.Add "xlPARENO", "=""("""
    ActiveWorkbook.Names.Add "xlPARENC", "="")"""
    ActiveWorkbook.Names.Add "xlPIPE", "=""|"""
    
End Sub

Public Sub AddConstantNames()

ActiveWorkbook.Names.Add "xlCOMMA", "="","""

ActiveWorkbook.Names.Add "xlSPACE", "="" """

ActiveWorkbook.Names.Add "xlDOUBLE", "="""""

ActiveWorkbook.Names.Add "xlSINGLE", "=""'"""

ActiveWorkbook.Names.Add "xlPARENO", "=""("""

ActiveWorkbook.Names.Add "xlPARENC", "="")"""

ActiveWorkbook.Names.Add "xlPIPE", "=""|"""

End Sub

=JoinRange(A2:A7,xlCOMMA,xlPARENO,xlPARENC,xlSINGLE)

1	=JoinRange(A2:A7,xlCOMMA,xlPARENO,xlPARENC,xlSINGLE)

I’m not crazy. I swear this all makes sense in my head. Plus, if you’ve read this far, you’re probably crazy too.

Anagrams and Palindromes

Posted on January 14, 2016 by Dick Kusleika

More Java homework:

Public Function IsAnagram(ByVal sWordOne As String, ByVal sWordTwo As String) As Boolean
    
    Dim vaOne As Variant
    Dim vaTwo As Variant
    Dim bReturn As Boolean
    Dim i As Long
    
    Const sRPLC As String = "+"
    
    sWordOne = Replace(sWordOne, Space(1), vbNullString)
    sWordTwo = Replace(sWordTwo, Space(1), vbNullString)
    
    If Len(sWordOne) = Len(sWordTwo) Then
        For i = 1 To Len(sWordOne)
            sWordTwo = Replace(sWordTwo, Mid$(sWordOne, i, 1), sRPLC, 1, 1, vbTextCompare)
        Next i
        bReturn = sWordTwo = String(Len(sWordOne), sRPLC)
    Else
        bReturn = False
    End If
    
    IsAnagram = bReturn
    
End Function

Public Function IsAnagram(ByVal sWordOne As String, ByVal sWordTwo As String) As Boolean

Dim vaOne As Variant

Dim vaTwo As Variant

Dim bReturn As Boolean

Dim i As Long

Const sRPLC As String = "+"

sWordOne = Replace(sWordOne, Space(1), vbNullString)

sWordTwo = Replace(sWordTwo, Space(1), vbNullString)

If Len(sWordOne) = Len(sWordTwo) Then

For i = 1 To Len(sWordOne)

sWordTwo = Replace(sWordTwo, Mid$(sWordOne, i, 1), sRPLC, 1, 1, vbTextCompare)

Next i

bReturn = sWordTwo = String(Len(sWordOne), sRPLC)

Else

bReturn = False

End If

IsAnagram = bReturn

End Function

First, I remove all the spaces. Then I make sure the two words are the same length. Then I loop through all the letters in the first word, find them in the second word, and replace them with a plus sign. If the second word is all plus signs at the end, then it’s an anagram. My first thought was to put the letters in an array and sort them, but that’s too much looping.

Public Function IsPalindrome(ByVal sPhrase As String)
    
    Dim i As Long
    Dim bReturn As Boolean
    
    bReturn = True
    sPhrase = Replace(sPhrase, Space(1), vbNullString)
    
    For i = 1 To Len(sPhrase)
        If LCase(Mid$(sPhrase, i, 1)) <> LCase(Mid$(sPhrase, Len(sPhrase) + 1 - i, 1)) Then
            bReturn = False
            Exit For
        End If
    Next i
    
    IsPalindrome = bReturn
    
End Function

Public Function IsPalindrome(ByVal sPhrase As String)

Dim i As Long

Dim bReturn As Boolean

bReturn = True

sPhrase = Replace(sPhrase, Space(1), vbNullString)

For i = 1 To Len(sPhrase)

If LCase(Mid$(sPhrase, i, 1)) <> LCase(Mid$(sPhrase, Len(sPhrase) + 1 - i, 1)) Then

bReturn = False

Exit For

End If

Next i

IsPalindrome = bReturn

End Function

Nothing too fancy here. Again, I remove all the spaces. Then I compare the first letter to the last letter, the second letter to the penultimate letter, and so on. If there’s every not a match, set the return value to False and quit looking.

Daily Dose of Excel

Haphazardly Posted Excel Information and Other Stuff

Category: VBA

Adding Stuff to the Top of a Dictionary

Storing Stuff in VBA Lists

Fun with Excel; A Wheel Of Fortune

Deleting Pivot Table Drilldown Sheets

KwikOpen Update

Unique Entries in Userform Dependent Listboxes

Cleaning Up My JoinRange Arguments

Anagrams and Palindromes