Excel 查找关键字并复制到其他工作表

我目前有一个工作代码，它完全按照我的要求执行，在excel文档的特定部分循环查找某些关键字，然后将这些关键字粘贴到excel电子表格中的单独表格中。它只是很长，不允许重复超过10次。我想知道是否有人在询问用户是否有更多的关键字时选择vbNo之前，对如何使代码循环给出了建议

Option Compare Text

Sub Macro2()
'
' Macro2 Macro
'
' Keyboard Shortcut: Ctrl+h
'
Application.ScreenUpdating = False
Dim lastLine As Long
Dim findWhat As String
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
s = 2

For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then

        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1

If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1
If MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion) = vbNo Then Exit Sub

findWhat = CStr(InputBox("What word would you like to search for today?"))
lastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For i = 1 To lastLine
    For Each cell In Range("BU1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(s).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next
s = s + 1

---

您要做的是创建一个循环，该循环将继续，直到用户通过在输入框中单击“取消”选择停止为止。要启动循环，请设置循环检查变量，并继续等于在询问用户是否要继续的框上单击“是”的结果

然后，在执行代码后，询问用户是否希望添加其他单词。否则，循环将结束。如果是这样，循环将继续并执行另一个单词

这是一个开始

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 newsheet As Worksheet

s = 2

Continue = vbYes 'initialize loop variable
    Do While Continue = vbYes 'keep getting more use input until they state they do not want to continue

        findWhat = CStr(InputBox("What word would you like to search for today?"))
        lastLine = ActiveSheet.UsedRange.Rows.Count
        If findWhat = "" Then Exit Sub
        j = 1
    For i = 1 To lastLine
        For Each cell In Range("BU1").Offset(i - 1, 0)
            If InStr(cell.Text, findWhat) <> 0 Then
                toCopy = True
            End If
        Next
        If toCopy = True Then
            Set newsheet = activeworkbook.sheets.add
            newsheet.name = findWhat
            Rows(i).Copy Destination:=newsheet.Rows(j)
            j = j + 1
        End If
        Set newsheet = Nothing
        toCopy = False
    Next i
    s = s + 1
    'find out if user wishes to continue.
    Continue = MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion)
Loop

---

这将是一个更好的适合，因为代码正在工作，您正在寻求改进它。那里的接收效果会更好。如果你真的在那里发布，请确保在堆栈溢出时将其删除。我会从提取一些重复代码开始。非常感谢，我是该网站的新手，非常感谢你的建议。我投票结束这个问题，因为你要求审查工作代码。如果codereview.se的帮助中心对此类问题开放，您可以和schould首先查看他们的meta。在堆栈溢出时，这是不正确的。代码实际上并不完全有效。他们希望在无限量的单词中使用此功能，但只在20个单词中使用。也许这个问题可以写得更清楚，这是一个很好的起点，谢谢。我必须做的一件事是删除msgbox后面的“=vbNo”。非常感谢。另外，您知道一种方法，我可以让它自动创建一个工作表，该工作表的名称是用户输入的吗？如果toCopy=True，那么它会在后面输入吗？你好！虽然这实际上可以回答这个问题，但并不是每个人都像你这样有知识。介意再解释一下吗？谢谢太棒了，我还编辑了代码，让s=2出现在循环之前，这样它将正确地递增，而不是每次都重置为两个循环。如何将新工作表添加到工作簿的末尾而不是开始？我尝试了Worksheets.Add After:=SheetsActiveWorkbook.Sheets.Count，它抛出了一个错误。@Vogel612，看起来他正在让它添加一个新的工作表，并将工作表名称设置为等于循环开始时的用户输入。如果代码在找到所有结果后结束，则不会创建新工作表。