使用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

这里有一个建议....利用FindWindow函数尖端

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

，您可以使用分割功能。 所以，你的这部分代码：

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