Multicriteria搜索關鍵字並複製到VBA中的另一個工作表

Question

我目前正在研究一個宏，該宏允許用戶使用關鍵字在Excel工作表中搜索數據，然後將所有結果與該關鍵字一起復制到新工作表中。我已經能夠獲得基本的搜索，表單生成和重命名，但我還希望能夠排除和包含除關鍵字以外的其他因素的結果。例如：搜索關鍵字「眼鏡」，僅包括在其前面具有「我需要」，「我需要」，「我需要」這些詞的項目。

或 搜索關鍵字「眼鏡」，並且不返回有「已包含了」，「不需要」項目等

基本上我希望能夠磨練搜索更多的位使樣品更精確。有沒有人有任何想法如何將這樣的異常和內含物包含到宏中？

Option Compare Text 

Public Sub Macro2() 
' 
' Macro2 Macro 
' 
' Keyboard Shortcut: Ctrl+h 
' set variables 
Dim Continue As Long 
Dim findWhat As String 
Dim LastLine As Long 
Dim toCopy As Boolean 
Dim cell As Range 
Dim i As Long 
Dim j As Long 
Dim sheetIndex As Long 


sheetIndex = 2 'start on the second sheet index to keep from overwriting data sheet 

Continue = vbYes 
    Do While Continue = vbYes 'set condition to cause loop 

     findWhat = CStr(InputBox("What word would you like to search for today?")) 'prompt user for input 
     n = CStr(InputBox("Exclusions?")) 'asks user for any exceptions 
     LastLine = ActiveSheet.UsedRange.Rows.Count 
     If findWhat = "" Then Exit Sub 'end execution if no entry 
     j = 1 
    For i = 1 To LastLine 'loop through interactions 
     For Each cell In Range("BU1").Offset(i - 1, 0) 
      If (InStr(1, cell, n, 1) = 0) Then 
       toCopy = False 
      If InStr(cell.Text, findWhat) <> 0 Then 
       toCopy = True 
      End If 
     Next 
     If toCopy = True Then 
      Sheets(sheetIndex).Name = UCase(findWhat) 'name sheet based on keyword entered 
      Rows(i).Copy Destination:=Sheets(sheetIndex).Rows(j) 'copy interactions to new sheet 
      j = j + 1 
     End If 
     toCopy = False 
    Next i 
    sheetIndex = sheetIndex + 1 'increment sheetindex by one 
    Continue = MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) 'prompt user to see if more input required 
Loop 
End Sub 

Answer 1

你只需要一點添加到您的測試/對比循環：

Option Explicit 

Public Sub Macro2() 
    ' 
    ' Macro2 Macro 
    ' 
    ' Keyboard Shortcut: Ctrl+h 
    ' set variables 
    Dim Continue As Long 
    Dim findWhat As String 
    Dim LastLine As Long 
    Dim toCopy As Boolean 
    Dim cell As Range 
    Dim i As Long 
    Dim j As Long 
    Dim sheetIndex As Long 
    Dim inclusions() As String 
    Dim exclusions() As String 
    Dim testString As Variant 
    Dim pos1 As Integer, pos2 As Integer 
    Dim matchFound As Boolean 

    sheetIndex = 2 'start on the second sheet index to keep from overwriting data sheet 

    '--- you can create these from your input box or cells on a worksheet 
    ' (the code below tests for the case: "I want glasses but do not need them" 
    inclusions = Split("I need,I want,I require", ",", , vbTextCompare) 
    exclusions = Split("already have,do not need", ",", , vbTextCompare) 

    Continue = vbYes 
    Do While Continue = vbYes 'set condition to cause loop 

     findWhat = CStr(InputBox("What word would you like to search for today?")) 'prompt user for input 
     LastLine = ActiveSheet.UsedRange.Rows.Count 
     If findWhat = "" Then Exit Sub 'end execution if no entry 
     j = 1 
     For i = 1 To LastLine 'loop through interactions 
      matchFound = False 
      For Each cell In Range("BU1").Offset(i - 1, 0) 
       pos1 = InStr(cell.Text, findWhat) 
       If pos1 <> 0 Then 
        '--- now check for inclusions/exclusions 
        '  ---> add checks for an empty inclusion/exclusion list 
        '   and what you should do about it 
        For Each testString In inclusions 
         pos2 = InStr(cell.Text, testString) 
         If (pos2 > 0) And (pos2 < pos1) Then 'checks before match 
          matchFound = True 
          Exit For 
         End If 
        Next testString 
        For Each testString In exclusions 
         pos2 = InStr(cell.Text, testString) 
         If (pos2 > 0) And (pos2 > pos1) Then 'checks after match 
          matchFound = False    'set False to skip this 
          Exit For 
         End If 
        Next testString 
        If matchFound Then 
         Sheets(sheetIndex).Name = UCase(findWhat) 'name sheet based on keyword entered 
         Rows(i).Copy Destination:=Sheets(sheetIndex).Rows(j) 'copy interactions to new sheet 
         j = j + 1 
        End If 
       End If 
      Next 
     Next i 
     sheetIndex = sheetIndex + 1 'increment sheetindex by one 
     Continue = MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) 'prompt user to see if more input required 
    Loop 
End Sub