Question

我目前正在开发一个允许用户使用关键字在Excel工作表中搜索数据的宏，然后将该关键字的所有结果复制到新工作表中。我已经能够通过一些帮助获得基本搜索，工作表生成和重命名，但是我还希望包括基于关键字以外的因素排除和包含结果的功能。

例如：搜索关键字＆＃34;眼镜＆＃34;，只包含带有＆＃34;我需要＆＃34;，＆＃34;我想要＆＃34;，＆＃34; I的项目要求＆＃34;在它面前。

或搜索关键词＆＃34;眼镜＆＃34;并且不要退回已经拥有＆＃34;，＆＃34;不需要＆＃34;等的项目。

基本上我希望能够更多地磨练搜索以使样本更精确。有没有人对如何在宏中包含这样的异常和包含有任何想法？

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

Multicriteria在VBA中搜索关键字并复制到另一个工作表

1 个答案: