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中的提示，您可以使用split功能。那么，这部分代码：

int a = -3; // Pattern 11111111.11111111.11111111.11111101
a = a >> 1; // Pattern 11111111.11111111.11111111.11111110 = -2

将修改为：

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

使用VBA

3 个答案: