Question

我的代码循环遍历文件夹，并将文本值添加到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

Answer 1

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

如果说你要找的文字总是在2个数字之间;例如，Agreement位于20170614中的01和20170614Agreement01_MSD.xls之间，那么我们可以采用这种方法

将此功能添加到您的代码

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

Answer 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”。

也许有一种方法可以使用“选择案例”方法，但我认为这比我的解决方案需要更多的工作。

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

2 个答案: