如果文件名包含特定文本，则执行

【问题标题】：If file name contains specific text then execute如果文件名包含特定文本，则执行
【发布时间】：2017-11-29 02:10:10
【问题描述】：

我的代码循环遍历文件夹并将 G1、H1、I1 等文本值添加到工作簿。

在图 1 中，您可以看到我的文件夹中有多个文件。不同的 Excel 文件或工作簿会添加不同的文本值。

要添加到“Professional”工作簿的文本值与要添加到“ProfessionalAddress”或“ProfessionalCommunication”的文本值不同。

我曾尝试使用InStr，但这将采用包含特定文本的任何文件名。
例如，我有几个包含单词“Professional”的文件，这意味着代码会将“Professional”文件的文本值添加到所有包含“Professional”文本的文件中。

我需要当文件名包含“Professional”时添加这些文本值，当文件包含“ProfessionalAddress”时添加这些文本值。对于“会议”“组织”“客户”也是如此。

图 1 

Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Ensure Workbook has opened before moving on to next line of code
      DoEvents

            If InStr(myFile, "Professional") > 0 Then

    'Add Column Headings
      wb.Worksheets(1).Range("F1").Value = "Error code"
      Range("G1").Value = "Error description"
      Range("H1").Value = "ActionCode"
      Range("I1").Value = "ProfessionalId"
      Range("J1").Value = "StatusCode"
      Range("K1").Value = "ProfessionalTypeCode"
      Range("L1").Value = "StatusDate"
      Range("M1").Value = "Qualification"
      Range("N1").Value = "ProfessionalSubtypeCode"
      Range("O1").Value = "FirstName"
      Range("P1").Value = "MiddleName"
      Range("Q1").Value = "LastName"
      Range("R1").Value = "SecondLastName"
      Range("S1").Value = "MeNumber"
      Range("T1").Value = "ImsPrescriberId"
      Range("U1").Value = "NdcNumber"
      Range("V1").Value = "TitleCode"
      Range("W1").Value = "ProfessionalSuffixCode"
      Range("X1").Value = "GenderCode"
      Range("Y1").Value = "Reserved for future use"
      Range("Z1").Value = "Reserved for future use"
      Range("AA1").Value = "Reserved for future use"
      Range("AB1").Value = "Reserved for future use"
      Range("AC1").Value = "SourceDataLevelCode"
      Range("AD1").Value = "PatientsPerDay"
      Range("AE1").Value = "PrimarySpecialtyCode"
      Range("AF1").Value = "SecondarySpecialtyCode"
      Range("AG1").Value = "TertiarySpecialtyCode"
      Range("AH1").Value = "NationalityCode"
      Range("AI1").Value = "TypeOfStudy"
      Range("AJ1").Value = "UniversityAffiliation"
      Range("AK1").Value = "SpeakerStatusCode"
      Range("AL1").Value = "OneKeyId"
      Range("AM1").Value = "NucleusId"
      Range("AN1").Value = "Suffix"
      Range("AO1").Value = "ClientField1"
      Range("AP1").Value = "ClientField2"
      Range("AQ1").Value = "ClientField3"
      Range("AR1").Value = "ClientField4"
      Range("AS1").Value = "ClientField5"
      Range("AT1").Value = "Reserved for future use"
      Range("AU1").Value = "NPICountry"
      Range("AV1").Value = "CountryCode"
      Range("AW1").Value = "Reserved for future use"
      Range("AX1").Value = "MassachusettsId"
      Range("AY1").Value = "NPIId"
      Range("AZ1").Value = "UniversityCity"
      Range("BA1").Value = "UniversityPostalArea"

    End If

    If InStr(myFile, "ProfessionalAddress") > 0 Then

    'Add Column Headings
      wb.Worksheets(1).Range("F1").Value = "Error code"
      Range("G1").Value = "Error description"
      Range("H1").Value = "ActionCode"
      Range("I1").Value = "ProfessionalAddressId"
      Range("J1").Value = "EffectiveDate"
      Range("K1").Value = "StatusCode"
      Range("L1").Value = "ProfessionalId"
      Range("M1").Value = "AddressTypeCode"
      Range("N1").Value = "StatusDate"
      Range("O1").Value = "Reserved for future use"
      Range("P1").Value = "AddressLine1"
      Range("Q1").Value = "AddressLine2"
      Range("R1").Value = "AddressLine3"
      Range("S1").Value = "City"
      Range("T1").Value = "State"
      Range("U1").Value = "PostalArea"
      Range("V1").Value = "PostalAreaExtension"
      Range("W1").Value = "CountryCode"
      Range("X1").Value = "Reserved for future use"
      Range("Y1").Value = "Reserved for future use"
      Range("Z1").Value = "Reserved for future use"
      Range("AA1").Value = "DeaNumber"
      Range("AB1").Value = "DeaExpirationDate"
      Range("AC1").Value = "LocationName"
      Range("AD1").Value = "EndDate"
      Range("AE1").Value = "N/A"

    End If

    If InStr(myFile, "ProfessionalStateLicense") > 0 Then

    'Add Column Headings
      wb.Worksheets(1).Range("F1").Value = "Error code"
      Range("G1").Value = "Error description"
      Range("H1").Value = "ActionCode"
      Range("I1").Value = "ProfessionalLicenseId"
      Range("J1").Value = "EffectiveDate"
      Range("K1").Value = "EndDate"
      Range("L1").Value = "ProfessionalId"
      Range("M1").Value = "StateLicenseNumber"
      Range("N1").Value = "StateLicenseState"
      Range("O1").Value = "StateLicenseExpirationDate"
      Range("P1").Value = "SamplingStatusCode"
      Range("Q1").Value = "Reserved for future use"
      Range("R1").Value = "N/A"

    End If


     If InStr(myFile, "ProfessionalCommunication") > 0 Then

    'Add Column Headings
      wb.Worksheets(1).Range("F1").Value = "Error code"
      Range("G1").Value = "Error description"
      Range("H1").Value = "ActionCode"
      Range("I1").Value = "ProfessionalCommunicationId"
      Range("J1").Value = "ProfessionalId"
      Range("K1").Value = "CommunicationTypeCode"
      Range("L1").Value = "CommunicationValue1"
      Range("M1").Value = "CommunicationValue2"
      Range("N1").Value = "ProfessionalAddressId"
      Range("O1").Value = "N/A"

    End If

      If InStr(myFile, "Organization") > 0 Then

    'Add Column Headings
      wb.Worksheets(1).Range("F1").Value = "Error code"
      Range("G1").Value = "Error description"
      Range("H1").Value = "ActionCode"
      Range("I1").Value = "OrganizationId"
      Range("J1").Value = "StatusCode"
      Range("K1").Value = "OrganizationTypeCode"
      Range("L1").Value = "StatusDate"
      Range("M1").Value = "Reserved for future use"
      Range("N1").Value = "OrganizationSubtypeCode"
      Range("O1").Value = "OrganizationName"
      Range("P1").Value = "NPICountry"
      Range("Q1").Value = "Reserved for future use"
      Range("R1").Value = "Reserved for future use"
      Range("S1").Value = "Reserved for future use"
      Range("T1").Value = "Reserved for future use"
      Range("U1").Value = "SourceDataLevelCode"
      Range("V1").Value = "Reserved for future use"
      Range("W1").Value = "Reserved for future use"
      Range("X1").Value = "OneKeyId"
      Range("Y1").Value = "FederalTaxId"
      Range("Z1").Value = "Reserved for future use"
      Range("AA1").Value = "NucleusId"
      Range("AB1").Value = "Reserved for future use"
      Range("AC1").Value = "ClientField1"
      Range("AD1").Value = "ClientField2"
      Range("AE1").Value = "ClientField3"
      Range("AF1").Value = "ClientField4"
      Range("AG1").Value = "ClientField5"
      Range("AH1").Value = "MassachusettsId"
      Range("AI1").Value = "NPIId"
      Range("AJ1").Value = "N/A"

    End If

      If InStr(myFile, "OrganizationAddress") > 0 Then

    'Add Column Headings
      wb.Worksheets(1).Range("F1").Value = "Error code"
      Range("G1").Value = "Error description"
      Range("H1").Value = "ActionCode"
      Range("I1").Value = "OrganizationAddressId"
      Range("J1").Value = "EffectiveDate"
      Range("K1").Value = "StatusCode"
      Range("L1").Value = "OrganizationId"
      Range("M1").Value = "AddressTypeCode"
      Range("N1").Value = "StatusDate"
      Range("O1").Value = "Reserved for future use"
      Range("P1").Value = "AddressLine1"
      Range("Q1").Value = "AddressLine2"
      Range("R1").Value = "AddressLine3"
      Range("S1").Value = "City"
      Range("T1").Value = "State"
      Range("U1").Value = "PostalArea"
      Range("V1").Value = "PostalAreaExtension"
      Range("W1").Value = "CountryCode"
      Range("X1").Value = "Reserved for future use"
      Range("Y1").Value = "Reserved for future use"
      Range("Z1").Value = "Reserved for future use"
      Range("AA1").Value = "DeaNumber"
      Range("AB1").Value = "DeaExpirationDate"
      Range("AC1").Value = "LocationName"
      Range("AD1").Value = "EndDate"
      Range("AE1").Value = "N/A"

    End If

      If InStr(myFile, "OrganizationCommunication") > 0 Then

    'Add Column Headings
      wb.Worksheets(1).Range("F1").Value = "Error code"
      Range("G1").Value = "Error description"
      Range("H1").Value = "ActionCode"
      Range("I1").Value = "OrganizationCommunicationId"
      Range("J1").Value = "OrganizationId"
      Range("K1").Value = "CommunicationTypeCode"
      Range("L1").Value = "CommunicationValue1"
      Range("M1").Value = "CommunicationValue2"
      Range("N1").Value = "OrganizationAddressId"
      Range("O1").Value = "N/A"

    End If

     If InStr(myFile, "OrganizationSpecialty") > 0 Then

    'Add Column Headings
      wb.Worksheets(1).Range("F1").Value = "Error code"
      Range("G1").Value = "Error description"
      Range("H1").Value = "ActionCode"
      Range("I1").Value = "OrganizationSpecialtyId"
      Range("J1").Value = "OrganizationId"
      Range("K1").Value = "SpecialtyTypeCode"
      Range("L1").Value = "SpecialtyCode"
      Range("M1").Value = "N/A"    

    End If

      If InStr(myFile, "Agreement01_MSD") > 0 Then

    'Add Column Headings
      wb.Worksheets(1).Range("F1").Value = "Error code"
      Range("G1").Value = "Error description"
      Range("H1").Value = "ActionCode"
      Range("I1").Value = "AgreementId"
      Range("J1").Value = "CompanyId"
      Range("K1").Value = "AgreementName"
      Range("L1").Value = "AgreementType"
      Range("M1").Value = "StatusCode"
      Range("N1").Value = "Description"
      Range("O1").Value = "AgreementDate"
      Range("P1").Value = "CustomerId"
      Range("Q1").Value = "ApprovalDate"
      Range("R1").Value = "StartDate"
      Range("S1").Value = "EndDate"
      Range("T1").Value = "SignatureDate"
      Range("U1").Value = "SecondaryCustomerId"
      Range("V1").Value = "AgreementCountry"
      Range("W1").Value = "ClientField1"
      Range("X1").Value = "ClientField2"
      Range("Y1").Value = "ClientField3"
      Range("Z1").Value = "ClientField4"
      Range("AA1").Value = "ClientField5"
      Range("AB1").Value = "ClientDate1"
      Range("AC1").Value = "ClientDate2"
      Range("AD1").Value = "ClientNumber1"
      Range("AE1").Value = "ClientNumber2"
      Range("AF1").Value = "DataSourceId"
      Range("AG1").Value = "CreationUser"
      Range("AH1").Value = "CommentText"
      Range("AI1").Value = "FirstName"
      Range("AJ1").Value = "MiddleName"
      Range("AK1").Value = "LastName"
      Range("AL1").Value = "AddressId"
      Range("AM1").Value = "AddressLine1"
      Range("AN1").Value = "AddressLine2"
      Range("AO1").Value = "AddressLine3"
      Range("AP1").Value = "City"
      Range("AQ1").Value = "State"
      Range("AR1").Value = "PostalArea"
      Range("AS1").Value = "Country"
      Range("AT1").Value = "SecondaryFirstName"
      Range("AU1").Value = "SecondaryMiddleName"
      Range("AV1").Value = "SecondaryLastName"
      Range("AW1").Value = "SecondaryAddressId"
      Range("AX1").Value = "SecondaryAddressLine1"
      Range("AY1").Value = "SecondaryAddressLine2"
      Range("AZ1").Value = "SecondaryAddressLine3"
      Range("BA1").Value = "SecondaryCity"
      Range("BB1").Value = "SecondaryState"
      Range("BC1").Value = "SecondaryPostalArea"
      Range("BD1").Value = "SecondaryCountry"
      Range("BE1").Value = "EventVenue"
      Range("BG1").Value = "EventName"
      Range("BG1").Value = "EventDate"
      Range("BH1").Value = "AgreementVenueOrganizer"
      Range("BI1").Value = "AgreementReason"

    End If

    If InStr(myFile, "Consent11_MSD") > 0 Then

    'Add Column Headings
      wb.Worksheets(1).Range("F1").Value = "Error code"
      Range("G1").Value = "Error description"
      Range("H1").Value = "ActionCode"
      Range("I1").Value = "ConsentId"
      Range("J1").Value = "CompanyId"
      Range("K1").Value = "ConsentType"
      Range("L1").Value = "ConsentIndicator"
      Range("M1").Value = "CustomerId"
      Range("N1").Value = "ExpensePurposeCode"
      Range("O1").Value = "EffectiveDate"
      Range("P1").Value = "EndDate"
      Range("Q1").Value = "ConsentDate"
      Range("R1").Value = "CommentText"
      Range("S1").Value = "AgreementId"
      Range("T1").Value = "CustomerExpenseId"
      Range("U1").Value = "MeetingId"
      Range("V1").Value = "DataSourceId"
      Range("W1").Value = "ClientField1"
      Range("X1").Value = "ClientField2"
      Range("Y1").Value = "ClientField3"
      Range("Z1").Value = "ClientField4"
      Range("AA1").Value = "ClientField5"
      Range("AB1").Value = "N/A"

    End If

    'Save and Close Workbook
      wb.Close SaveChanges:=True

    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

用于测试的精简代码

Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Ensure Workbook has opened before moving on to next line of code
      DoEvents

      myFile = "20170614Agreement01_MSD.xls"

            If getTextBtwnNumbers(myFile) = "Agreement" Then

    'Add Text
      wb.Worksheets(1).Range("F1").Value = "Error code"
      Range("G1").Value = "Error description"
      Range("H1").Value = "ActionCode"
      Range("I1").Value = "ProfessionalId"
      Range("J1").Value = "StatusCode"
      Range("K1").Value = "ProfessionalTypeCode"
      Range("L1").Value = "StatusDate"
      Range("M1").Value = "Qualification"
      'etc etc etc

    End If

    'Save and Close Workbook
      wb.Close SaveChanges:=True

    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Private Function getTextBtwnNumbers(s As String) As String
    Dim pos1 As Long, pos2 As Long
    Dim i As Long, j As Long

    For i = 1 To Len(s)
        If pos1 = 0 Then
            Select Case Asc(Mid(s, i, 1))
            Case 65 To 90, 97 To 122
                pos1 = i
            End Select
        Else
            For j = pos1 To Len(s)
                Select Case Asc(Mid(s, j, 1))
                Case 65 To 90, 97 To 122
                Case Else
                    pos2 = j ' - 1
                    Exit For
                End Select
            Next j
        End If

        If pos1 <> 0 And pos2 <> 0 Then Exit For
    Next i

    If pos1 <> 0 And pos2 <> 0 Then
        getTextBtwnNumbers = Trim(Mid(s, pos1, pos2 - pos1))
    Else
        getTextBtwnNumbers = "Invalid Text Format"
    End If
End Function

【问题讨论】：

  • 是的，我绝对可以在这里以最少的方式完成。谢谢你的提示:-)

标签： vba excel filenames


【解决方案1】：

问题是文件名中的单词没有空格。在这种情况下，很难防止误报。

话虽如此，如果您要查找的文本始终介于 2 个数字之间；例如Agreement在20170614Agreement01_MSD.xls中的20170614和01之间，那么我们可以采用这种方法

将此函数添加到您的代码中

Private Function getTextBtwnNumbers(s As String) As String
    Dim pos1 As Long, pos2 As Long
    Dim i As Long, j As Long

    For i = 1 To Len(s)
        If pos1 = 0 Then
            Select Case Asc(Mid(s, i, 1))
            Case 65 To 90, 97 To 122
                pos1 = i
            End Select
        Else
            For j = pos1 To Len(s)
                Select Case Asc(Mid(s, j, 1))
                Case 65 To 90, 97 To 122
                Case Else
                    pos2 = j ' - 1
                    Exit For
                End Select
            Next j
        End If

        If pos1 <> 0 And pos2 <> 0 Then Exit For
    Next i

    If pos1 <> 0 And pos2 <> 0 Then
        getTextBtwnNumbers = Trim(Mid(s, pos1, pos2 - pos1))
    Else
        getTextBtwnNumbers = "Invalid Text Format"
    End If
End Function

然后你就可以这样使用了

Sub Sample()
    Dim flName As String

    flName = "20170614Agreement01_MSD.xls"

    If getTextBtwnNumbers(flName) = "Agreement" Then
        MsgBox "Match Found"
    End If
End Sub

注意：

我假设文本将在NumberTEXTNumber 格式的两个数字之间。

如果您的格式为NumberTEXTONENumberTEXTTWONumber，则该函数将仅提取TEXTONE

编辑

我意识到使用LIKE 有更好的方法。这样就不需要上面的函数了。

Sub Sample()
    Dim flName As String, Searchtext As String

    flName = "20170614Agreement01_MSD.xls"

    Searchtext = "Agreement"

    If flName Like "*#" & Searchtext & "#*.xls" Then MsgBox "Match Found"
End Sub

【讨论】：

  • 嗨，悉达多。感谢您抽出宝贵时间回复，非常感谢。我喜欢您的代码示例作为解决方案，但不幸的是，前面和后面的数字并非每次都保持不变。 20170614 是一个日期，这将改变。但也许我们可以用另一种方式工作，如果我有删除文件名中字符的代码怎么办。然后我可以告诉循环代码嘿寻找“协议”。这种方法行得通吗？？？
  • 数字是多少并不重要 :) 必须有一个数字.. 不管它是什么。它可以是111AAA222 或20170614Agreement01_MSD 或123345678SID43211456 或任何东西。格式必须为NTN (NumberTextNumber)
  • 啊好吧：我会试一试。我在那里添加了一些代码，以开始您答案中的其他解决方案。在我尝试你原来的方法之前请忽略:-)哦，谢谢你的支持:-)非常感谢:-)
  • 我已经拒绝了您的编辑 :) 请不要编辑我的答案以发表澄清。随意编辑您的问题。
  • 只有一个词，那就是'SLICK' :-) 那是一些 SLICK VBA :-) 非常感谢 Siddharth :-)
【解决方案2】：

我建议您在“If”语句中使用“And”来对文件名进行更复杂的检查。

顺便说一句，如果你想让你的“InStr”函数只检查一个小字符串是否存在在一个更大的字符串中，你需要做的就是这样：

If InStr(myFile, "Professional") Then

而不是这样：

If InStr(myFile, "Professional") > 0 Then

这有点像在 If...Then 语句中返回“True”或“False”。

这是我对您的问题的解决方案：

Public Sub testStr()
Dim strVar As String
Dim myFile As String

myFile = "ProfessionalStateLicense"

If InStr(myFile, "Professional") And InStr(myFile, "StateLicense") Then
  MsgBox myFile
  ' do specific case
End If

End Sub

只需将“StateLicense”替换为您文件夹中的其他文件名潜文本示例即可。例如，将“StateLicense”替换为“Address”。

也可能有一种使用“选择案例”方法的方法，但我相信它比我的解决方案需要更多的工作。

【讨论】：

    猜你喜欢
    • 1970-01-01
    • 1970-01-01
    • 1970-01-01
    • 1970-01-01
    • 1970-01-01
    • 2020-07-31
    • 1970-01-01
    • 1970-01-01
    • 1970-01-01
    相关资源
    最近更新 更多
    热门标签
    Java Python linux javascript Mysql C# Docker 算法 前端 SpringBoot Redis Vue spring 设计模式 .net core .net kubernetes c++ 数据库 数据结构 大数据 js 机器学习 微服务 Android Go 程序员 面试 JVM ASP.net core 云原生 人工智能 后端 PHP git CSS golang k8s Nginx Django mybatis 深度学习 多线程 React 架构 devops 爬虫 云计算 Spring Boot LeetCode