使用VBA从文件名拉取可变长度的string
请参阅底部查看答案中使用的replace代码。
我正在处理一个电子表格，从目录中的文件列表中提取名称。 这些文件被命名为John Doe 01011980.xlsx和Janey B Deer 02031983.xlsx ，因此第一个和最后一个名字的长度是可变的，可以但不总是包含中间的首字母，然后是简化的出生date。 这是我正在使用的代码（这是行不通的）从文件名中sorting名称。
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
假设你的文件名一直有相似的格式，你可以尝试使用下面的代码。 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结尾，从结尾（最后一个空格直到结束）取出生日，然后得到第一个名字（开始直到第一个空格），然后是姓（最后一个空格直到结束）以及剩下的任何东西中间名。
这里有一个build议….
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
希望这可以帮助…
使用findwindow的提示，你可以使用splitfunction。 所以，你的代码的这一部分：
''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