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
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:
|
1 2 3 |
Application.OnKey "^+d", "PTDrillDown" Application.OnKey "^+d" |
That’s Ctrl+Shift+D for the uninitiated. That will now run PTDrillDown
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
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 |
Lot’s of
|
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.
|
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.
|
1 2 3 4 5 6 7 8 9 |
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.
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.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
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.
…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.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
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 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.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
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.
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
|
1 |
In |
clause in SQL. Let’s say I have this list of customer IDs and I want to make an
|
1 |
In |
clause.
| 38 |
| 142 |
| 146 |
| 175 |
| 214 |
| 217 |
I’d use JoinRange like
|
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
|
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.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
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:
|
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…
|
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
|
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.
|
1 2 3 4 5 6 7 8 9 10 11 |
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 |
|
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.
More Java homework:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
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.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
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.
Add-ins have worksheets. You just can’t see them. But you can store information on them and it’s a good way to store settings, preferences, and other data. When you want to get to that data, you can go to the Properties for ThisWorkbook and change the IsAddin property to False. Now you can see the worksheets and change the data if necessary.
When you’re done, go back to the VBE and change the IsAddin property back to True before you save your changes. Don’t forget that part; it’s important.
I have a list of vendor codes stored on a worksheet in an addin. I need to see the list, but not change it. I didn’t want to go through all the IsAddin rigmarole, so I did this in the Immediate Window.
|
1 |
wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.value |
That part returns a two-dimensional array of all the values in the first column
|
1 |
application.transpose(...) |
That turns a two-dimensional array into a one-dimensional array.
|
1 |
?join(...,",") |
That turns an array into a string with commas between the values. In retrospect, I should have used
|
1 |
?join(application.transpose(wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.value),vbnewline) |
to get each code on its own line. Here’s a way to put it into a range, if that’s where you’re going with it anyway.
|
1 |
wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.Copy workbooks.Add.Worksheets(1).cells(1,1) |
If you use, rely on, tell stories with, worry about, or operate in the advanced areas of Excel, then there’s a track designed just for you.
This is a unique opportunity to:
Use your opportunities, including two Panel discussions and Q&A sessions, throughout the two days to ask questions and discuss with the Excel MVPs and the industry experts.
The Excel Dev Team members will use this opportunity to learn from their customers, understand how you use Excel and get feedback on your Excel experience.
NETWORK AND ENJOY AT THE MODELOFF EVENING MEETUP EVENTThe ModelOff Meetup event delivers plenty of opportunities to mingle, learn from your peers, talk to the speakers and have fun.
