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

Question

提问by Philip Connell

I have code that loops through a folder and adds text values to G1, H1, I1 etc etc. to Workbooks.

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

In Pic 1 you see I have several files in my folder. Different Excel files or Workbooks get different Text Values added to them.

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

The Text Values to be added to the "Professional" Workbook are different from the Text Values to be added to "ProfessionalAddress" or "ProfessionalCommunication".

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

I have tried to use InStrbut this will take any file name that contains a certain piece of text.
For example I have several files that contain the word "Professional" this means that the code then adds the text values for "Professional" file to all files that contain the text "Professional".

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

I need when a file name contains "Professional" add these Text Values, when a file contains "ProfessionalAddress" add these Text Values. Likewise for "Meeting" "Organization" "Customer".

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

Pic 1

图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

STRIPPED DOWN CODE FOR TEST

用于测试的精简代码

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

Answer 1

采纳答案by Siddharth Rout

The problem is that there is no space in the words in the file names. In such a scenario it becomes difficult to prevent False Positives.

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

Having said that if the text that you are looking for will always be between 2 numbers; for example Agreementis between 20170614and 01in 20170614Agreement01_MSD.xlsthen we may take this approach

话虽如此，如果您要查找的文本始终介于 2 个数字之间；例如Agreement之间20170614，并01在20170614Agreement01_MSD.xls随后我们可能会采取这种方法

Add this function to your code

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

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

And then you can use it like this

然后你可以像这样使用它

Sub Sample()
    Dim flName As String

    flName = "20170614Agreement01_MSD.xls"

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

Note:

笔记：

I am assuming that the text will be between 2 numbers in the format NumberTEXTNumber.

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

If you have a format which is NumberTEXTONENumberTEXTTWONumberthen the function will only extract TEXTONE

如果您有一个格式，NumberTEXTONENumberTEXTTWONumber那么该函数只会提取TEXTONE

EDIT

编辑

I realised that there is a better way using LIKE. This way you will not need the above function.

我意识到有更好的方法使用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

Answer 2

回答by Mike

I suggest you use "And" in your "If" statements to do a more complex check of your file name.

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

By the way, if you want your "InStr" function to just check if a small string is presentin a bigger string all you need to do is something like this:

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

If InStr(myFile, "Professional") Then

rather then this:

而不是这样：

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

This is kind of like returning "True" or "False" to your If...Then statement.

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

Here is my solution to your problem:

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

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

Just replace "StateLicense" with the other examples of filenames' subtext that you have in your folder. For example, replace "StateLicense" with "Address".

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

There may be a way to use the "Select Case" method as well, but I believe it would take more work than my solution.

可能还有一种方法可以使用“Select Case”方法，但我相信它比我的解决方案需要更多的工作。

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

提问by Philip Connell

采纳答案by Siddharth Rout

回答by Mike

相关推荐

最近更新

标签

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

提问by Philip Connell

采纳答案by Siddharth Rout

回答by Mike

相关推荐

在 VBA 中用平滑线编码散点图

vba 每 30 分钟移动一次鼠标指针

Excel vba 将值从一张纸更改为另一张纸

使用 VBA 将 Excel 工作表的（部分）范围导出为 CSV

相关推荐

最近更新

标签