Pulling variable-length strings from file name using VBA

Question

See bottom for replacement code used from answers.

I am working with a spreadsheet that pulls names from a list of files in a directory. The files are named like John Doe 01011980.xlsx and Janey B Deer 02031983.xlsx, therefore the first and last name are of variable length, can but does not always include a middle initial and is followed by a simplified date of birth. Here is the code I am currently using (which does not work) to sort the name out of the file name.

Private Sub nextname_Click()

Dim strDir As String, first As String, last As String, dateofbirth As String, check As String

strDir = Worksheets("Sheet1").Range("A1").Text
strDir = Dir
If strDir = "" Then
    Unload Me
    MsgBox ("I couldn't find any other client files by that name.")
    Exit Sub
End If

check = Left(strDir, InStr(1, strDir, ".xlsx", vbTextCompare) - 10)

''THE ISSUE IS CONTAINED HEREIN
If InStr(1, check, " * ", vbTextCompare) > 0 Then
    first = Trim(Left(check, Len(check) - InStr(1, check, " ", vbTextCompare) - 2))
    last = Trim(Right(check, Len(check) - InStr(1, check, " ", vbTextCompare) - 2))
Else
    first = Trim(Left(check, Len(check) - InStr(1, check, " ", vbTextCompare)))
    last = Trim(Right(check, Len(check) - InStr(1, check, " ", vbTextCompare)))
End If
''END ISSUE

dateofbirth = mid(strDir, Len(strDir) - 12, 2) & "/" & mid(strDir, Len(strDir) - 10, 2) & "/" & mid(strDir, Len(strDir) - 8, 4)

Worksheets("Sheet1").Range("A1") = "C:\filepath\" & strDir

reviewNameUserform.first_Text.Text = first
reviewNameUserform.last_Text.Text = last
reviewNameUserform.dob_Text.Text = dateofbirth

The issue as marked above is in pulling the first and last name out of the file name, most especially when there is a middle initial. Currently it is only using the Else statement to display John and Doe or Janey B and B Deer, when I want it to detect if there is a middle initial and then pull out John and Doe or Janey and Deer. I fiddled around a lot with Left, Right, Mid, and InStr to no avail.

---

Replaced

check = Left(strDir, InStr(1, strDir, ".xlsx", vbTextCompare) - 10)

''THE ISSUE IS CONTAINED HEREIN
If InStr(1, check, " * ", vbTextCompare) > 0 Then
    first = Trim(Left(check, Len(check) - InStr(1, check, " ", vbTextCompare) - 2))
    last = Trim(Right(check, Len(check) - InStr(1, check, " ", vbTextCompare) - 2))
Else
    first = Trim(Left(check, Len(check) - InStr(1, check, " ", vbTextCompare)))
    last = Trim(Right(check, Len(check) - InStr(1, check, " ", vbTextCompare)))
End If
''END ISSUE

dateofbirth = mid(strDir, Len(strDir) - 12, 2) & "/" & mid(strDir, Len(strDir) - 10, 2) & "/" & mid(strDir, Len(strDir) - 8, 4)

with

If InStr(filename, ".xlsx") = 0 Then
    MsgBox ("There is no file with that extension.")
    'Possibly include code to check for .xlsm or other extensions.
    Exit Sub
ElseIf (Len(filename) - Len(Replace(filename, " ", ""))) < 2 Then
    MsgBox ("File name format does not match expected format. File name format is FIRST M LAST mmddyyyy.xlsx")
    'Possibly include code to check for misnamed files.
    Exit Sub
Else
    filename = strDir
    filename = mid(filename, 1, InStr(filename, ".xlsx") - 1)
    dateofbirth = mid(filename, InStrRev(filename, " ") + 1)
    filename = mid(filename, 1, InStrRev(filename, " ") - 1)

    first = mid(filename, 1, InStr(filename, " ") - 1)
    filename = mid(filename, InStr(filename, " ") + 1)

    last = mid(filename, InStrRev(filename, " ") + 1)
    middlename = Trim(mid(filename, 1, InStr(filename, " ")))
End If

dateofbirth = mid(dateofbirth, 1, 2) & "/" & mid(dateofbirth, 3, 2) & "/" & mid(dateofbirth, 5, 4)

'Preserved for later use.
'namesData = Split(Replace(strDir, ".xlsx", ""), " ")
'first = namesData(0)
'If UBound(namesData) = 3 Then
'    middlename = namesData(1)
'    last = namesData(2)
'    dateofbirth = namesData(3)
'ElseIf UBound(namesData) = 2 Then
'    last = namesData(1)
'    dateofbirth = namesData(2)
'End If

and added

reviewNameUserform.middle_Text.Text = middlename

Answer 1

using the tip from findwindow, you can use the split function. So, this part of your code:

''THE ISSUE IS CONTAINED HEREIN
If InStr(1, check, " * ", vbTextCompare) > 0 Then
    first = Trim(Left(check, Len(check) - InStr(1, check, " ", vbTextCompare) - 2))
    last = Trim(Right(check, Len(check) - InStr(1, check, " ", vbTextCompare) - 2))
Else
    first = Trim(Left(check, Len(check) - InStr(1, check, " ", vbTextCompare)))
    last = Trim(Right(check, Len(check) - InStr(1, check, " ", vbTextCompare)))
End If
''END ISSUE

will be modified to:

'USING SPLIT
namesData = Split(Replace(strDir,".xlsx","")," ")
first = namesData(0)
If UBound(namesData)=3 Then
    last = namesData(2)
    dateofbirth = namesData(3)
ElseIf UBound(namesData)=2 Then
    last = namesData(1)
    dateofbirth = namesData(2)
End If

Answer 2

Assuming your file names have a similar format all the time, you could try using the following code. filename can be John Doe 01011980.xlsx or Janey B Deer 02031983.xlsx.

If InStr(filename, ".xlsx") = 0 Then
    MsgBox "missing .xlsx"
ElseIf (Len(filename) - Len(Replace(filename, " ", ""))) < 2 Then
    MsgBox "input format seems weird, not enough spaces"
Else
    filename = Mid(filename, 1, InStr(filename, ".xlsx") - 1)
    dateofbirth  = Mid(filename, InStrRev(filename, " ") + 1)
    filename = Mid(filename, 1, InStrRev(filename, " ") - 1)

    first = Mid(filename, 1, InStr(filename, " ") - 1)
    filename = Mid(filename, InStr(filename, " ") + 1)

    last = Mid(filename, InStrRev(filename, " ") + 1)
    middlename = Trim(Mid(filename, 1, InStr(filename, " ")))
End If

The code first removes the .xlsx ending, the takes the birthdate from the end (last space until end), then gets the first name (start until first space), then the family name (last space until end) and whatever is left becomes the middle name.

Answer 3

here's a suggestion....

Private Sub nextname_Click()

    Dim strDir As String, first As String, last As String, dateofbirth As String, check As String

    strDir = Worksheets("Sheet1").Range("A1").Text
    strDir = Dir
    If strDir = "" Then
        Unload Me
        MsgBox ("I couldn't find any other client files by that name.")
        Exit Sub
    End If

    check = Left(strDir, InStr(1, strDir, ".xlsx", vbTextCompare) - 10)

    ''THE SOLUTION IS CONTAINED HEREIN
       check = Trim(check)
       first = Split(check, " ")(LBound(Split(check, " ")))
       last = Split(check, " ")(UBound(Split(check, " ")))

    ''END SOLUTION

    dateofbirth = mid(strDir, Len(strDir) - 12, 2) & "/" & mid(strDir, Len(strDir) - 10, 2) & "/" & mid(strDir, Len(strDir) - 8, 4)

    Worksheets("Sheet1").Range("A1") = "C:\filepath\" & strDir

    reviewNameUserform.first_Text.Text = first
    reviewNameUserform.last_Text.Text = last
    reviewNameUserform.dob_Text.Text = dateofbirth

Hope this helps...