Вытягивание строк переменной длины из имени файла с использованием VBA

Question

См. Нижнюю часть кода замены, используемого в ответах.

Я работаю с электронной таблицей, которая извлекает имена из списка файлов в каталоге. Файлы называются John Doe 01011980.xlsx и Janey B Deer 02031983.xlsx, поэтому первое и фамильное имя имеют переменную длину, могут, но не всегда включают средний начальный и сопровождаются упрощенной датой рождения. Вот код, который я сейчас использую (который не работает), чтобы отсортировать имя из имени файла.

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 

вопрос, как отмечено выше, в потянув имя и фамилию из имени файла, в особенности, когда есть отчества. В настоящее время только с помощью Else заявления для отображения John и Doe или Janey B и B Deer, когда я хочу, чтобы обнаружить, если есть отчества, а затем вытащить John и Doe или Janey и Deer. Я много раз поиграл с Left, Right, Mid и InStr безрезультатно.

---

Заменено

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) 

с

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 

и добавил

reviewNameUserform.middle_Text.Text = middlename 

Answer 1

Предполагая, что ваши имена файлов имеют формат, аналогичный все время, вы можете попробовать использовать следующее код. filename может быть John Doe 01011980.xlsx или 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 

Код первый удаляет .xlsx окончание, то берет дату рождения с конца (последнее пространство до конца), то получает первое имя (не начинается до первого пробела), то имя семьи (последнее место до конец), и все остальное становится средним именем.

Answer 2

вот предложение ....

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 

Надеется, что это помогает ...

Answer 3

используя наконечник с FindWindow, вы можете использовать функцию разделения. Таким образом, эта часть кода:

''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 

будет изменен на:

'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