Retrieving Data from Add-in Worksheets

Posted on December 9, 2015December 8, 2015 by Dick Kusleika

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.

wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.value

1	wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.value

That part returns a two-dimensional array of all the values in the first column

application.transpose(...)

1	application.transpose(...)

That turns a two-dimensional array into a one-dimensional array.

?join(...,",")

1	?join(...,",")

That turns an array into a string with commas between the values. In retrospect, I should have used

?join(application.transpose(wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.value),vbnewline)

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.

wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.Copy workbooks.Add.Worksheets(1).cells(1,1)

1	wshvendors.ListObjects(1).ListColumns(1).DataBodyRange.Copy workbooks.Add.Worksheets(1).cells(1,1)

Announcing Excel Summit South: Auckland Sydney Melbourne in March 2016

Posted on November 23, 2015 by Charles Williams

It has taken me 2 years to put this series of Excel conferences in Australia and New Zealand together.

Now please help me spread the word!

For the first time ever some of the world’s leading authorities on Excel and spreadsheet models are coming together to share their knowledge.

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.

EXTEND YOUR SKILLS

This is a unique opportunity to:

Learn from six of the world’s leading Excel MVP’s as they discuss the Excel topics most useful to you.
Hear industry leading speakers from around the world give you the latest views on Financial Modelling best practices, standards and spreadsheet risk.
Shape the future of Excel: Interact with members of the Microsoft Excel Dev Team as you explore with them the future of Excel.
Choose the sessions that best suit your needs from 23 masterclass sessions over two days of twin tracks for modellers and analysts.

INTERACT WITH THE EXPERTS AND MEMBERS OF THE EXCEL DEV TEAM

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.

EXCEL SUMMIT SOUTH PLACES ARE LIMITED: REGISTER NOW

EarlyBird 20% discount available for registrations before December 31 2015.
Don’t miss out out on this unique Excel opportunity.

NETWORK AND ENJOY AT THE MODELOFF EVENING MEETUP EVENT

The ModelOff Meetup event delivers plenty of opportunities to mingle, learn from your peers, talk to the speakers and have fun.

PROUDLY SUPPORTED BY

Editing SQL Statements in External Data Queries

Posted on October 8, 2015 by Dick Kusleika

Surprisingly, I’ve been using the

SendKeys

SendKeys

macro from this post quite a bit. SendKeys is dangerous, as I’ve said, but I like to live on the edge. Jan Karel commented that I should use Alt-DDE, which gives me the Command Text box to edit the SQL query, but doesn’t give me the opportunity to change the name of the Connection. As I thought about it more, changing the Connection name happens one time and isn’t really the major source of my frustration. In fact, if I were a little more disciplined I could change the name when I setup the Connection in the Friendly Name box.

Then it’s settled. I’ll use Alt-DDE to edit the SQL and I’ll force myself to set the name when I set it up. But wait. One of the things I was really looking forward to in building my own Command Text box was making it bigger by default so I could see the whole SQL string (or at least most of it). The Alt-DDE textbox is only slightly better than the Connection properties Command Text textbox. See for yourself.

That’s a crappy UI. And that’s from someone who spends a lot of time in the Visual Basic Editor.

Then it’s settled. I’ll build my own form for changing the properties I want to change. It’s what I really wanted to do anyway, so why stop lying to myself. What kind of features should I build into this UI? A big textbox is a must. Also, I’d like to be able to add white space and line breaks. Oh, and if I could have SQL parsing, autoformatting, and autocomplete… So basically what I want is SQL Server Management Studio. I already have that. It’s called SQL Server Management Studio. That lead me to my next bit of genius. If I want to edit the SQL, even only a little, I should do it in SSMS. I added a couple of buttons to the Ribbon.

The Copy button copies the SQL to the clipboard, ready for me to paste into SSMS.

Public Sub CopySql()
    
    Dim doClip As MSForms.DataObject
    Dim qt As QueryTable
    
    On Error Resume Next
        Set qt = ActiveCell.ListObject.QueryTable
    On Error GoTo 0
    
    If Not qt Is Nothing Then
        Set doClip = New DataObject
        doClip.SetText qt.CommandText
        doClip.PutInClipboard
    End If
    
End Sub

Public Sub CopySql()

Dim doClip As MSForms.DataObject

Dim qt As QueryTable

On Error Resume Next

Set qt = ActiveCell.ListObject.QueryTable

On Error GoTo 0

If Not qt Is Nothing Then

Set doClip = New DataObject

doClip.SetText qt.CommandText

doClip.PutInClipboard

End If

End Sub

I leave the button enabled and check to make sure a QueryTable exists in the procedure. If I wanted to enable/disable the button, I would need to run a SelectionChange event constantly. I didn’t test it, but it seems like too much overhead. The Paste button looks like this

Public Sub PasteSql()
    
    Dim doClip As MSForms.DataObject
    Dim qt As QueryTable
    Dim sOld As String
    
    On Error Resume Next
        Set qt = ActiveCell.ListObject.QueryTable
    On Error GoTo 0
    
    If Not qt Is Nothing Then
        sOld = qt.CommandText
        Set doClip = New DataObject
        doClip.GetFromClipboard
        qt.CommandText = doClip.GetText
        doClip.SetText sOld
        doClip.PutInClipboard
    End If
    
End Sub

Public Sub PasteSql()

Dim doClip As MSForms.DataObject

Dim qt As QueryTable

Dim sOld As String

On Error Resume Next

Set qt = ActiveCell.ListObject.QueryTable

On Error GoTo 0

If Not qt Is Nothing Then

sOld = qt.CommandText

Set doClip = New DataObject

doClip.GetFromClipboard

qt.CommandText = doClip.GetText

doClip.SetText sOld

doClip.PutInClipboard

End If

End Sub

I added one little safety step in here because I know how I am. I take what’s in the clipboard and insert it into the

CommandText

1	CommandText

property. But I put the previous

CommandText

1	CommandText

in the Clipboard when I’m done. That way, when I get distracted and accidentally put something else in the Clipboard before I paste, I can (relatively) easily revert back to what it was.

I’ll give this a try and see how it goes.

One unsolicited plug: I use Red Gate’s SQL Prompt in SSMS. I can’t imaging having to work in SSMS without it. It’s pricey, but if you’re spending any time in SSMS, you should give it a try.

Connection Properties of External Data Ranges

Posted on September 25, 2015 by Dick Kusleika

I have a workbook with several connections to SQL Server. When I need to change the SQL statement, I do that in Connection Properties.

I added a command to the QAT to show the connection properties dialog, but there’s something I don’t like about it. If I’m in a table with a connection, it’s pretty likely that I want to see the properties of that particular connection and not just a list of all connections. Of course I’m awesome at naming my connections so I don’t have to guess which is which, but if you weren’t so awesome you might have trouble distinguishing them.

The long-term answer is to write my own interface to change the things I want to change. But in the mean time, I want to open the connections dialog and highlight the connection related to the table I’m in, if any.

Public Sub ShowConnection()
    
    Dim qt As QueryTable
    Dim sConName As String
    Dim i As Long
    
    On Error Resume Next
        Set qt = ActiveCell.ListObject.QueryTable
    On Error GoTo 0
    
    If Not qt Is Nothing Then
        sConName = qt.WorkbookConnection.Name
        Application.CommandBars.ExecuteMso "Connections"
        
        Application.Wait Now + TimeSerial(0, 0, 2)
        
        For i = 1 To Len(sConName)
            SendKeys Mid$(sConName, i, 1)
        Next i
    Else
        Application.CommandBars.ExecuteMso "Connections"
    End If
    
End Sub

Public Sub ShowConnection()

Dim qt As QueryTable

Dim sConName As String

Dim i As Long

On Error Resume Next

Set qt = ActiveCell.ListObject.QueryTable

On Error GoTo 0

If Not qt Is Nothing Then

sConName = qt.WorkbookConnection.Name

Application.CommandBars.ExecuteMso "Connections"

Application.Wait Now + TimeSerial(0, 0, 2)

For i = 1 To Len(sConName)

SendKeys Mid$(sConName, i, 1)

Next i

Else

Application.CommandBars.ExecuteMso "Connections"

End If

End Sub

When I open the Connections dialog, I can start typing the name of the connection to get down to it. For example, I could start typing “dup” and it will highlight the first connection that starts with those keys.

With SendKeys, I can type the entire name. First I see if the ActiveCell is in a QueryTable. If it’s not, I just open the dialog. If it is, I open the dialog, wait a couple seconds, then send all the keys in the connection’s name. SendKeys can be very dangerous, but we’re just experimenting here.

What the above code actually does is open the Connections dialog, wait for it to close, then send all those keystrokes into the ActiveCell. Dangerous. And not helpful. Apparently the Connections dialog is modal and all code is suspended until it’s closed. I did a little searching and found this command, which does not help.

Application.CommandBars.ReleaseFocus

1	Application.CommandBars.ReleaseFocus

Maybe the old CommandBars behave differently than the Ribbon.

Application.CommandBars.FindControl(, 11205).Execute

1	Application.CommandBars.FindControl(, 11205).Execute

Nope. Same as ExecuteMso. One last try. This opens the dialog with SendKeys.

        sConName = qt.WorkbookConnection.Name
        SendKeys "%ao"
        
        Application.Wait Now + TimeSerial(0, 0, 2)
        
        For i = 1 To Len(sConName)
            SendKeys Mid$(sConName, i, 1)
        Next i

sConName = qt.WorkbookConnection.Name

SendKeys "%ao"

Application.Wait Now + TimeSerial(0, 0, 2)

For i = 1 To Len(sConName)

SendKeys Mid$(sConName, i, 1)

Next i

And it works. For some reason sending Alt+A+O opens the Connections dialog modeless, the SendKeys executes, and takes me to the “active” connection. I have a couple of applications on my machine that like to steal the focus, so I try to avoid SendKeys whenever I can (which is always). In this code, I’m using it twice, so I won’t be using it all. Interesting, though, that it seems to be the only way to get what I want.

Along the way, I discovered I could get to the “active” connection’s property sheet with this key sequence:

right-click key
b
a
tab
tab
enter

I guess that will work. It’s a lot of keystrokes, though.

MaxMinFair Rewrite

Posted on September 18, 2015 by Dick Kusleika

I read Charles William’s MaxMinFair algorithm and I didn’t like his approach. That’s typical. I’ll read somebody’s code and think “They’re making that too hard”. Then I’ll set about rewriting it. In this case, as in most cases, it turns out that it is that hard, but I wasn’t going to convince myself until I tried it. I ended up with a different approach that’s not shorter, not easier to read, and not easier to follow. Oh well, here it is anyway.

Function MaxMinFairDK(Supply As Double, Demands As Variant) As Variant
    
    Dim dPrior As Double
    Dim vaReturn As Variant
    Dim dAvailable As Double
    Dim i As Long, j As Long
    Dim dTemp As Double
    Dim wf As WorksheetFunction
    
    On Error GoTo ErrHandler
    Set wf = Application.WorksheetFunction
    If IsObject(Demands) Then Demands = Demands.Value2 'make range array
    dAvailable = Abs(Supply) 'ignore negative supplies
    
    If Not IsArray(Demands) Then
        'One demand = min of supply or demand
        MaxMinFairDK = Array(dAvailable, Demands)(Abs(dAvailable > Demands))
    Else
        'Excel returns NA when you use too many columns
        If UBound(Demands, 2) > 1 Then Err.Raise xlErrNA
        'Assume everybody gets everything they want
        ReDim vaReturn(LBound(Demands, 1) To UBound(Demands, 1), 1 To 1)
        vaReturn = Demands
        
        For i = UBound(Demands, 1) To LBound(Demands, 1) Step -1
            'If there's enough, do nothing except reduce what's available
            If dAvailable / i > (wf.Large(Demands, i) - dPrior) Then
                dAvailable = dAvailable - ((wf.Large(Demands, i) - dPrior) * i)
                dPrior = wf.Large(Demands, i)
            Else
                'Once there's not enough, everyone splits what's left
                For j = LBound(Demands, 1) To UBound(Demands, 1)
                    If Demands(j, 1) > dPrior Then
                        vaReturn(j, 1) = dPrior + (dAvailable / i)
                    End If
                Next j
                Exit For
            End If
        Next i
        
        MaxMinFairDK = vaReturn
    End If
    
ErrExit:
    Exit Function
    
ErrHandler:
    MaxMinFairDK = CVErr(Err.Number)
    Resume ErrExit
    
End Function

Function MaxMinFairDK(Supply As Double, Demands As Variant) As Variant

Dim dPrior As Double

Dim vaReturn As Variant

Dim dAvailable As Double

Dim i As Long, j As Long

Dim dTemp As Double

Dim wf As WorksheetFunction

On Error GoTo ErrHandler

Set wf = Application.WorksheetFunction

If IsObject(Demands) Then Demands = Demands.Value2 'make range array

dAvailable = Abs(Supply) 'ignore negative supplies

If Not IsArray(Demands) Then

'One demand = min of supply or demand

MaxMinFairDK = Array(dAvailable, Demands)(Abs(dAvailable > Demands))

Else

'Excel returns NA when you use too many columns

If UBound(Demands, 2) > 1 Then Err.Raise xlErrNA

'Assume everybody gets everything they want

ReDim vaReturn(LBound(Demands, 1) To UBound(Demands, 1), 1 To 1)

vaReturn = Demands

For i = UBound(Demands, 1) To LBound(Demands, 1) Step -1

'If there's enough, do nothing except reduce what's available

If dAvailable / i > (wf.Large(Demands, i) - dPrior) Then

dAvailable = dAvailable - ((wf.Large(Demands, i) - dPrior) * i)

dPrior = wf.Large(Demands, i)

Else

'Once there's not enough, everyone splits what's left

For j = LBound(Demands, 1) To UBound(Demands, 1)

If Demands(j, 1) > dPrior Then

vaReturn(j, 1) = dPrior + (dAvailable / i)

End If

Next j

Exit For

End If

Next i

MaxMinFairDK = vaReturn

End If

ErrExit:

Exit Function

ErrHandler:

MaxMinFairDK = CVErr(Err.Number)

Resume ErrExit

End Function

In Charles’s implementation, he allocates an equal amount of the supply to each node, then takes back what that node didn’t need and puts it back in the available pool. When I was looking at the results, I was thinking that the smallest n nodes simply get their demand and only when there’s not enough to go around do we need to do something different than allocate the full demand.

In my implementation, I start by giving everyone what they demand. Then I start with the smallest demand, and if I can accommodate that amount for everyone, I just reduce the amount available and move to the second smallest demand. At some point (the sixth smallest demand in Charles’s data) I can’t meet that demand and still give everyone an equal share. At that point, I give anyone who hasn’t had their demand met an equal amount – the amount that’s already been distributed plus an equal share of what’s left.

Rank	Demand	Incremental Demand	Allocated	Remaining
				18.30
7	0.70	0.70	4.90	13.40
6	1.00	0.30	1.80	11.60
5	1.30	0.30	1.50	10.10
4	2.00	0.70	2.80	7.30
3	3.50	1.50	4.50	2.80
2	7.40	3.90	7.80	(5.00)
1	10.00	2.60	2.60	(7.60)

In the first iteration, I hand out 0.70 to everyone because I have enough supply to do that. In the second iteration, I had out the differential, 0.30, to everyone who’s left because I have enough supply remaining. When I get to #2, I can’t hand out 3.90 to the remaining two nodes because I don’t have enough supply. I’ve allocated up to 3.5 to anyone who’s demanded it, so the last two get the 3.5 plus half of the 2.8 that remains.

Although I didn’t accomplish anything, it was still a fun exercise.

From True and False to Yes and No

Posted on September 16, 2015 by Dick Kusleika

I’m writing some code to turn the contents of class modules into an XML file for Affordable Care Act compliance purposes. The XML file spec says that my flag for whether the dependent is a spouse is “Y” or “N”. In my class, I have a Relation property that can be “Son”, “Daughter”, or “Spouse”. I made a new property to return the “Y” or “N”.

Public Property Get IsSpouseXML() As String
    
    If Me.Relation = "Spouse" Then
        IsSpouseXML = "Y"
    Else
        IsSpouseXML = "N"
    End If
    
End Property

Public Property Get IsSpouseXML() As String

If Me.Relation = "Spouse" Then

IsSpouseXML = "Y"

Else

IsSpouseXML = "N"

End If

End Property

I hate writing all those lines to convert a Boolean into something else. I know it’s not that big of a deal, but it just bugs me. So I fixed it.

Public Property Get IsSpouseXML() As String
    
    IsSpouseXML = Split("N Y")(Abs(Me.Relation = "Spouse"))
        
End Property

Public Property Get IsSpouseXML() As String

IsSpouseXML = Split("N Y")(Abs(Me.Relation = "Spouse"))

End Property

Now that’s fancy. The comparison is made and the True or False is converted to a Long via the Abs() function (to turn True to 1 instead of -1) and the proper element of the array is selected. It’s still not good enough.

Public Property Get IsSpouse() As Boolean
    
    IsSpouse = Me.Relation = "Spouse"
    
End Property

Public Property Get IsSpouseXML() As String
    
    IsSpouseXML = Split("N Y")(Abs(Me.IsSpouse))
        
End Property

Public Property Get IsSpouse() As Boolean

IsSpouse = Me.Relation = "Spouse"

End Property

Public Property Get IsSpouseXML() As String

IsSpouseXML = Split("N Y")(Abs(Me.IsSpouse))

End Property

Yeah, that’s better. But it’s so specific to spouses. Spouse is a dependent that gets special attention, so I don’t mind having a dedicated property to it. It’s appropriate for the domain, I think. But if I wanted to really generalize the hell out of it, I might make an IsRelation property and then take my conversion property into a function.

Public Property Get IsRelation(ByVal sRelation As String) As Boolean
    
    IsRelation = Me.Relation = sRelation
    
End Property

Public Function ConvertBool(bValue As Boolean, vArr As Variant) As String
    
    ConvertBool = vArr(Abs(bValue))
    
End Function

Public Property Get IsRelation(ByVal sRelation As String) As Boolean

IsRelation = Me.Relation = sRelation

End Property

Public Function ConvertBool(bValue As Boolean, vArr As Variant) As String

ConvertBool = vArr(Abs(bValue))

End Function

Now I can have complete customization of the return string.

Public Sub TEST_IsSpouse()
    
    Dim clsDep As CDependent
    
    For Each clsDep In gclsEmployees.Employee(4).Dependents
        Debug.Print ConvertBool(clsDep.IsRelation("Spouse"), Array("Not so much", "Of course")), clsDep.Relation
    Next clsDep
    
End Sub

Public Sub TEST_IsSpouse()

Dim clsDep As CDependent

For Each clsDep In gclsEmployees.Employee(4).Dependents

Debug.Print ConvertBool(clsDep.IsRelation("Spouse"), Array("Not so much", "Of course")), clsDep.Relation

Next clsDep

End Sub

Searching Text Files in a Directory

Posted on August 17, 2015 by Dick Kusleika

I have several years of vendor invoices, in text file format, in some directories on a share. I need to search through these text files to find an order number, manifest number, or some other piece of information. I can’t search everything because it would take too long. And I don’t have control over the server, so if there is some indexing that could be done, I can’t do it. I’m stuck with good old VBA.

The folders are yyyymmdd (ex: 20150725 for July 25th) and corresponds to the invoice dates for any invoices in the file. Each file starts with a three letter abbreviation of the vendors name. Invoice date and vendor name are the only two pieces of information I can use to limit the search. The final piece of information is, of course, the search term. Here’s what the form looks like

I have a table of vendors and codes to populate the Vendor combobox. The QuickDate combobox populates the Date Range textboxes and contains common date ranges, namely, Last Month, This Month, Last Quarter, This Quarter, Last Year, This Year. I can change the dates to whatever I want if there isn’t a Quick Date that suits me. The Search Terms textbox takes a space separated list of terms to search for.

And now the fun part. The code. This converts the Quick Dates into real dates

Private Sub cbxQuick_Change()
    
    Dim dtStart As Date, dtEnd As Date
    
    Select Case Me.cbxQuick.Value
        Case "Last Month"
            dtStart = DateSerial(Year(Now), Month(Now) - 1, 1)
            dtEnd = DateSerial(Year(Now), Month(Now), 0)
        Case "This Month"
            dtStart = DateSerial(Year(Now), Month(Now), 1)
            dtEnd = DateSerial(Year(Now), Month(Now) + 1, 0)
        Case "Last Quarter"
            dtStart = DateSerial(Year(Now), Month(Now) - (((Month(Now) - 1) Mod 3) + 3), 1)
            dtEnd = DateSerial(Year(dtStart), Month(dtStart) + 3, 0)
        Case "This Quarter"
            dtStart = DateSerial(Year(Now), Month(Now) - (((Month(Now) - 1) Mod 3)), 1)
            dtEnd = DateSerial(Year(dtStart), Month(dtStart) + 3, 0)
        Case "Last Year"
            dtStart = DateSerial(Year(Now) - 1, 1, 1)
            dtEnd = DateSerial(Year(Now), 1, 0)
        Case "This Year"
            dtStart = DateSerial(Year(Now), 1, 1)
            dtEnd = DateSerial(Year(Now) + 1, 1, 0)
    End Select
    
    Me.tbxStartDate.Text = Format(dtStart, "mm/dd/yyyy")
    Me.tbxEndDate.Text = Format(dtEnd, "mm/dd/yyyy")
    
End Sub

Private Sub cbxQuick_Change()

Dim dtStart As Date, dtEnd As Date

Select Case Me.cbxQuick.Value

Case "Last Month"

dtStart = DateSerial(Year(Now), Month(Now) - 1, 1)

dtEnd = DateSerial(Year(Now), Month(Now), 0)

Case "This Month"

dtStart = DateSerial(Year(Now), Month(Now), 1)

dtEnd = DateSerial(Year(Now), Month(Now) + 1, 0)

Case "Last Quarter"

dtStart = DateSerial(Year(Now), Month(Now) - (((Month(Now) - 1) Mod 3) + 3), 1)

dtEnd = DateSerial(Year(dtStart), Month(dtStart) + 3, 0)

Case "This Quarter"

dtStart = DateSerial(Year(Now), Month(Now) - (((Month(Now) - 1) Mod 3)), 1)

dtEnd = DateSerial(Year(dtStart), Month(dtStart) + 3, 0)

Case "Last Year"

dtStart = DateSerial(Year(Now) - 1, 1, 1)

dtEnd = DateSerial(Year(Now), 1, 0)

Case "This Year"

dtStart = DateSerial(Year(Now), 1, 1)

dtEnd = DateSerial(Year(Now) + 1, 1, 0)

End Select

Me.tbxStartDate.Text = Format(dtStart, "mm/dd/yyyy")

Me.tbxEndDate.Text = Format(dtEnd, "mm/dd/yyyy")

End Sub

This makes sure a real date is entered, but provides for 6 or 8 digit date entry.

Private Sub tbxEndDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    
    If IsDate(Me.tbxEndDate.Value) Then
        tbxEndDate.Text = FormatDateTime(tbxEndDate.Value, vbShortDate)
    ElseIf Len(tbxEndDate.Text) = 6 Then
        tbxEndDate.Text = DateSerial(Right(tbxEndDate.Text, 2), Left(tbxEndDate.Text, 2), Mid(tbxEndDate.Text, 3, 2))
    ElseIf Len(tbxEndDate.Text) = 8 Then
        tbxEndDate.Text = DateSerial(Right(tbxEndDate.Text, 4), Left(tbxEndDate.Text, 2), Mid(tbxEndDate.Text, 3, 2))
    Else
        MsgBox "You must enter a valid date."
        Cancel = True
    End If

End Sub

Private Sub tbxEndDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)

If IsDate(Me.tbxEndDate.Value) Then

tbxEndDate.Text = FormatDateTime(tbxEndDate.Value, vbShortDate)

ElseIf Len(tbxEndDate.Text) = 6 Then

tbxEndDate.Text = DateSerial(Right(tbxEndDate.Text, 2), Left(tbxEndDate.Text, 2), Mid(tbxEndDate.Text, 3, 2))

ElseIf Len(tbxEndDate.Text) = 8 Then

tbxEndDate.Text = DateSerial(Right(tbxEndDate.Text, 4), Left(tbxEndDate.Text, 2), Mid(tbxEndDate.Text, 3, 2))

Else

MsgBox "You must enter a valid date."

Cancel = True

End If

End Sub

And the big one, the actual search. This is pretty long and needs to be refactored, but it works for now.

Private Sub cmdSearch_Click()
    
    Dim vaTerms As Variant
    Dim i As Long, j As Long
    Dim aFolders() As String
    Dim sFolder As String, sFile As String, lFile As Long
    Dim lCnt As Long
    Dim dtFolder As Date
    Dim sText As String
    
    Const sPATH As String = "\\yourserver\rawdata\"
        
    Me.lbxResults.Clear
    
    ReDim aFolders(1 To 1000)
    sFolder = Dir(sPATH & "*", vbDirectory)
        
    'get a list of folders in the date range
    Do While Len(sFolder) > 0
        If Len(sFolder) = 8 Then
            dtFolder = DateSerial(Left$(sFolder, 4), Mid$(sFolder, 5, 2), Right$(sFolder, 2))
            If dtFolder >= CDate(Me.tbxStartDate.Text) And dtFolder <= CDate(Me.tbxEndDate.Text) Then
                lCnt = lCnt + 1
                aFolders(lCnt) = sFolder
                sFolder = Dir
            End If
        End If
        sFolder = Dir
    Loop
    
    ReDim Preserve aFolders(1 To lCnt)
        
    lCnt = 0
    vaTerms = Split(Me.tbxSearch.Text, Space(1))
    
    'Make a dummy result
    Me.lbxResults.AddItem vbNullString
    
    For i = LBound(aFolders) To UBound(aFolders)
        sFolder = sPATH & aFolders(i) & "\"
        sFile = Dir(sFolder & Me.cbxVendor.Value & "*.IN?")
                
        Do While Len(sFile) > 0
            'Show the current folder as a result
            Me.lbxResults.Column(0, 0) = sFolder & sFile
            Me.Repaint
            
            'Open the file and read in all the text
            lFile = FreeFile
            Open sPATH & aFolders(i) & "\" & sFile For Binary As lFile
                sText = Space$(LOF(lFile))
                Get #1, , sText
            Close lFile
            
            'Loop through the space separated search terms and see if
            'they're in the file
            For j = LBound(vaTerms) To UBound(vaTerms)
                If InStr(1, sText, vaTerms(j), vbTextCompare) > 0 Then
                    'This is the animation part
                    Me.lbxResults.AddItem vbNullString, 0
                    Me.lbxResults.TopIndex = 0
                    lCnt = lCnt + 1
                    DoEvents
                    Exit For
                End If
            Next j
                
            sFile = Dir
        Loop
    Next i
    
    'Get rid of the dummy
    Me.lbxResults.RemoveItem 0
    
End Sub

Private Sub cmdSearch_Click()

Dim vaTerms As Variant

Dim i As Long, j As Long

Dim aFolders() As String

Dim sFolder As String, sFile As String, lFile As Long

Dim lCnt As Long

Dim dtFolder As Date

Dim sText As String

Const sPATH As String = "\\yourserver\rawdata\"

Me.lbxResults.Clear

ReDim aFolders(1 To 1000)

sFolder = Dir(sPATH & "*", vbDirectory)

'get a list of folders in the date range

Do While Len(sFolder) > 0

If Len(sFolder) = 8 Then

dtFolder = DateSerial(Left$(sFolder, 4), Mid$(sFolder, 5, 2), Right$(sFolder, 2))

If dtFolder >= CDate(Me.tbxStartDate.Text) And dtFolder <= CDate(Me.tbxEndDate.Text) Then

lCnt = lCnt + 1

aFolders(lCnt) = sFolder

sFolder = Dir

End If

sFolder = Dir

Loop

ReDim Preserve aFolders(1 To lCnt)

lCnt = 0

vaTerms = Split(Me.tbxSearch.Text, Space(1))

'Make a dummy result

Me.lbxResults.AddItem vbNullString

For i = LBound(aFolders) To UBound(aFolders)

sFolder = sPATH & aFolders(i) & "\"

sFile = Dir(sFolder & Me.cbxVendor.Value & "*.IN?")

Do While Len(sFile) > 0

'Show the current folder as a result

Me.lbxResults.Column(0, 0) = sFolder & sFile

Me.Repaint

'Open the file and read in all the text

lFile = FreeFile

Open sPATH & aFolders(i) & "\" & sFile For Binary As lFile

sText = Space$(LOF(lFile))

Get #1, , sText

Close lFile

'Loop through the space separated search terms and see if

'they're in the file

For j = LBound(vaTerms) To UBound(vaTerms)

If InStr(1, sText, vaTerms(j), vbTextCompare) > 0 Then

'This is the animation part

Me.lbxResults.AddItem vbNullString, 0

Me.lbxResults.TopIndex = 0

lCnt = lCnt + 1

DoEvents

Exit For

End If

Next j

sFile = Dir

Loop

Next i

'Get rid of the dummy

Me.lbxResults.RemoveItem 0

End Sub

It takes about 60 seconds per month to search the files. That’s a long time so it’s necessary to entertain the user while he waits. The top entry in the results listbox is whatever the current file is. It rapidly changes the display as it loops through the folder. When there’s a hit, that file becomes the second entry and any prior hits move down. This little animation lets the user know that it’s still working and gives him a list of what hits have been found already.

You can download SearchTextFiles.zip

Setting the Tab Order of Userform Controls Programmatically

Posted on August 6, 2015 by Dick Kusleika

I hate designing userforms. I mean the part where I’m lining up controls, renaming controls, and all the other super-fiddly parts of making a form look and act right – like setting the tab order. I always wait until the very end so I don’t have to do it twice. And that Tab Order dialog? Forget about it.

When I’m finally ready to set the tab order, I find the first control and click Move Up until it’s at the top. Next, I find the second control and click Move Up until it’s just below the first control. Then I go to Whammyburger and force them to serve me breakfast. Then I go back and do the rest of the controls. It’s maddening. I decided finally to do something about it.

First I set a reference to the VBA Extensibility Library.

Then I put this code in a standard module

Public Sub FixTabOrder()
    
    Dim ctl As Control
    Dim i As Long, j As Long
    Dim lCnt As Long
    Dim vbc As VBIDE.VBComponent
    
    'Change this to the name of your userform
    Set vbc = ThisWorkbook.VBProject.VBComponents("UInvoice")
    
    For i = 1 To vbc.Properties("Width")
        For j = 1 To vbc.Properties("Height")
            For Each ctl In vbc.Designer.Controls
                If ctl.Top = i And ctl.Left = j Then
                    ctl.TabIndex = lCnt
                    lCnt = lCnt + 1
                End If
            Next ctl
        Next j
    Next i
    
    For Each ctl In vbc.Designer.Controls
        Debug.Print ctl.Name, ctl.TabIndex
    Next ctl
    
End Sub

Public Sub FixTabOrder()

Dim ctl As Control

Dim i As Long, j As Long

Dim lCnt As Long

Dim vbc As VBIDE.VBComponent

'Change this to the name of your userform

Set vbc = ThisWorkbook.VBProject.VBComponents("UInvoice")

For i = 1 To vbc.Properties("Width")

For j = 1 To vbc.Properties("Height")

For Each ctl In vbc.Designer.Controls

If ctl.Top = i And ctl.Left = j Then

ctl.TabIndex = lCnt

lCnt = lCnt + 1

End If

Next ctl

Next j

Next i

For Each ctl In vbc.Designer.Controls

Debug.Print ctl.Name, ctl.TabIndex

Next ctl

End Sub

This is pretty brute force, but it only take a few seconds to run, so who cares. The i and j variables move through the userform point-by-point, left to right, top to bottom (that’s the typographical point, not the agenda items point). For every point on the userform, it loops through every control to see if that control starts at that point. If it finds one, it sets the controls TabIndex to the next number. At the end it just prints out the control names and tabs.

Even if that’s not exactly how I want my tab order, it gets it close and I can make other modifications manually.

If you have a super-wide or super-long form, it will take longer. The right way to do this is to put all the controls in an array and sort them by their Top and Left properties. If this method is too slow, you should write that up. Then send me a copy.

Daily Dose of Excel

Haphazardly Posted Excel Information and Other Stuff

Category: VBA

Retrieving Data from Add-in Worksheets

Announcing Excel Summit South: Auckland Sydney Melbourne in March 2016

It has taken me 2 years to put this series of Excel conferences in Australia and New Zealand together.

Now please help me spread the word!

For the first time ever some of the world’s leading authorities on Excel and spreadsheet models are coming together to share their knowledge.

EXTEND YOUR SKILLS

INTERACT WITH THE EXPERTS AND MEMBERS OF THE EXCEL DEV TEAM

EXCEL SUMMIT SOUTH PLACES ARE LIMITED: REGISTER NOW

EarlyBird 20% discount available for registrations before December 31 2015.
Don’t miss out out on this unique Excel opportunity.

NETWORK AND ENJOY AT THE MODELOFF EVENING MEETUP EVENT

PROUDLY SUPPORTED BY

Editing SQL Statements in External Data Queries

Connection Properties of External Data Ranges

MaxMinFair Rewrite

From True and False to Yes and No

Searching Text Files in a Directory

Setting the Tab Order of Userform Controls Programmatically

It has taken me 2 years to put this series of Excel conferences in Australia and New Zealand together.

Now please help me spread the word!

For the first time ever some of the world’s leading authorities on Excel and spreadsheet models are coming together to share their knowledge.

EXTEND YOUR SKILLS

INTERACT WITH THE EXPERTS AND MEMBERS OF THE EXCEL DEV TEAM

EXCEL SUMMIT SOUTH PLACES ARE LIMITED: REGISTER NOW

EarlyBird 20% discount available for registrations before December 31 2015. Don’t miss out out on this unique Excel opportunity.

NETWORK AND ENJOY AT THE MODELOFF EVENING MEETUP EVENT

PROUDLY SUPPORTED BY

EarlyBird 20% discount available for registrations before December 31 2015.
Don’t miss out out on this unique Excel opportunity.