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