Multicriteria在VBA中搜索关键字并复制到另一个工作表(Multicriteria search for keyword and copy to another sheet in VBA)

Multicriteria在VBA中搜索关键字并复制到另一个工作表(Multicriteria search for keyword and copy to another sheet in VBA)

我目前正在开发一个宏，允许用户使用关键字在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

I am currently working on a macro that allows a user to search through the data in an Excel worksheet using keywords, then copy all results with that keyword to a new sheet. I have been able to get the basic search, sheet generation and renaming down with some help, however I would also like to include the ability to exclude and include results based on factors other than keywords.

For instance: search for keyword "glasses", only include items that have the words "I need", "I want", "I require" in front of it.

or search for keyword "glasses" and do not return items that have "already have", "do not need", etc.

Basically I want to be able to hone the search a bit more to allow the samples to be more precise. Does anyone have any ideas of how to include exceptions and inclusions like this into the macro?

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

最满意答案

您只需在测试/比较循环中添加一点：

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

You just have to add a bit to your test/compare loop:

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 SubMulticriteria在VBA中搜索关键字并复制到另一个工作表(Multicriteria search for keyword and copy to another sheet in VBA)

我目前正在开发一个宏，允许用户使用关键字在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

I am currently working on a macro that allows a user to search through the data in an Excel worksheet using keywords, then copy all results with that keyword to a new sheet. I have been able to get the basic search, sheet generation and renaming down with some help, however I would also like to include the ability to exclude and include results based on factors other than keywords.

For instance: search for keyword "glasses", only include items that have the words "I need", "I want", "I require" in front of it.

or search for keyword "glasses" and do not return items that have "already have", "do not need", etc.

Basically I want to be able to hone the search a bit more to allow the samples to be more precise. Does anyone have any ideas of how to include exceptions and inclusions like this into the macro?

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

最满意答案

您只需在测试/比较循环中添加一点：

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

You just have to add a bit to your test/compare loop:

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