在所有打开的excel工作簿VBA中执行关键字搜索

我一直在研究很多Excel VBA宏代码，并取得了很多成果。我遇到了一个问题，我希望搜索一个关键字，该关键字可能在一个打开的Excel工作簿中可用，如-ABC12345，如果在单元格B2中找到ABC，我希望满足条件

到目前为止，我的代码是：

Sub ABC_Upload()
Sheets("Add File Here").Select
If IsEmpty(Range("A1")) Then
  Worksheets("Master Mapper").Activate

  Dim answerABC As Integer
answerABC = MsgBox("Please check the Data Sheet. No value found in first row! Do you wish to find XYZ file in open workbooks and start process?", vbYesNo + vbQuestion, "Review & Proceed")
If answerABC = vbYes Then

    'Starts here
    Dim wSheet As Worksheet
    Dim wBook As Workbook
    Dim XYZFound As Range
    Dim xFound As Boolean
    Dim lngLastRow2 As Long

    On Error Resume Next
    For Each wBook In Application.Workbooks
        For Each wSheet In wBook.Worksheets
            Set XYZFound = Nothing
            Set XYZFound = wSheet.Cells.Find(What:="ABC", After:=wSheet.Cells(1, 1), _
            LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=True)
            'Set XYZFound = wSheet.Cells.Find(What:="BIC", After:=wSheet.Cells(1, 1), _
            LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False)

            'XYZFound.Cells.Select
            If Not XYZFound Is Nothing Then
                xFound = True
                Application.Goto XYZFound, True
            'Rows(1, 2).EntireRow.Hidden = True
            lngLastRow2 = Cells(Cells.Rows.Count, "B").End(xlUp).Row
            Range("A1:E" & lngLastRow2).Copy
            ThisWorkbook.Worksheets("Add File Here").Activate
            Range("A1").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False

            End If

        Next wSheet
        If xFound Then Exit For
        Next wBook

If XYZFound Is Nothing Then
MsgBox "No open file for XYZ Meetings Found. Make sure the most recent XYZ Excel WB is open!", vbCritical + vbOKOnly
Exit Sub
End If
    'Ends Here

Sheets("Add File Here").Select
Columns("A").Replace _
 What:=";", Replacement:=""
Columns("A").Replace _
 What:=":", Replacement:=""
Columns("A").Replace _
 What:=",", Replacement:=""
Columns("A").Replace _
 What:="(", Replacement:=""
Columns("A").Replace _
 What:=")", Replacement:=""
Columns("A").Replace _
 What:="{", Replacement:=""
Columns("A").Replace _
 What:="}", Replacement:=""
Columns("A").Replace _
 What:="[", Replacement:=""
Columns("A").Replace _
 What:="]", Replacement:=""
Columns("A").Replace _
 What:="~+", Replacement:=""
Columns("A").Replace _
 What:="~*", Replacement:=""
Columns("A").Replace _
 What:="~?", Replacement:=""
Columns("A").Replace _
 What:="_", Replacement:=""
Columns("A").Replace _
 What:=".", Replacement:=""
Columns("A").Replace _
 What:="'", Replacement:=""
Columns("A").Replace _
 What:="\", Replacement:=""
Columns("A").Replace _
 What:="/", Replacement:=""
Columns("A").Replace _
 What:=".", Replacement:=""
Columns("A").Replace _
 What:="@", Replacement:=""
Columns("A").Replace _
 What:=Chr(34), Replacement:=""

Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("C1").Value = "Client ID"
Columns("D:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("D1").Value = "Client Name"
Columns("E:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("E1").Value = "Planner Name"
Columns("I:I").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("I1").Value = "External System Name"
Dim rng As Range
    Dim i As Long

    'Set the range in column A you want to loop through
    Set rng = Range("B2:B100")
    For Each cell In rng
        'test if cell is empty
        If cell.Value <> "" Then
            'write to adjacent cell
            cell.Offset(0, 1).Value = "Company ID"
        End If
    Next
Dim rngC As Range
    Dim Ci As Long

    'Set the range in column A you want to loop through
    Set rngC = Range("C2:C100")
    For Each cell In rngC
        'test if cell is empty
        If cell.Value <> "" Then
            'write to adjacent cell
            cell.Offset(0, 1).Value = "Company"
        End If
    Next
Dim rngP As Range
    Dim Pi As Long

    'Set the range in column A you want to loop through
    Set rngP = Range("D2:D100")
    For Each cell In rngP
        'test if cell is empty
        If cell.Value <> "" Then
            'write to adjacent cell
            cell.Offset(0, 1).Value = "NA"
        End If
    Next
Dim rnEP As Range
    Dim Ei As Long

    'Set the range in column A you want to loop through
    Set rngE = Range("H2:H100")
    For Each cell In rngE
        'test if cell is empty
        If cell.Value <> "" Then
            'write to adjacent cell
            cell.Offset(0, 1).Value = "Company"
        End If
    Next
'MsgBox "File has been formatted for XYZ and is ready for MMS upload.", vbOKOnly
Dim answer As Integer
answer = MsgBox("Temporary File Prepared for XYZ. Do you wish to proceed with MMS_NewMtgs file creation?", vbYesNo + vbQuestion, "Review & Proceed")
If answer = vbYes Then
    Call Prepare_OutputFile
Else
    MsgBox "Output file not created!! Please select - Click to create MMS Formatted File from Master Mapper.", vbOKOnly
End If
End If
End If
ThisWorkbook.Saved = True
End Sub

如有任何建议，将不胜感激

---

谢谢

您的问题是没有及时退出内部for循环。在处理完所有图纸后退出外部for，这将XYZfound设置回零

---

如果只需要查找一次，则将“退出”上移几行，并在处理工作簿中的下一张工作表之前终止循环

除了@nwhaught所说的之外，如果xFound=1，那么退出以进行测试是有问题的。xFound声明为布尔值，尽管您将其设置为1，但实际值为True。现在，对于VBA，True不等于1，If条件始终为False。VBA中True的值为-1，但您不需要这个值。只需使用If xFound然后Exit For，因为检查布尔值就足够了，无需将其与另一个布尔值进行比较。

您可以使用以下方法缩短搜索行：

    Columns("A").Replace ";", ""
    Columns("A").Replace ":", ""
    Columns("A").Replace ",", ""
    Columns("A").Replace "(", ""
    Columns("A").Replace ")", ""
    Columns("A").Replace "{", ""
                 . 
                 . 
                 . 
                 . 

这是使用With命令的一个很好的理由示例

或者这个：

    Dim badText As Variant
    For Each badText In Array(";", ":", ",", _
                               "(", ")", "{", "}", "[", "]", _
                               "~+", "~*", "~?", "_", ".", _
                               "'", "\", "/", "@", """")       ' chr(34) = " (quote), in VBA string it must be escaped by doubling it up

        Columns("A").Replace badText, ""
    Next badText

另一个需要简化的地方：

两个范围内容检查将文本公司放在每个非空单元格旁边的位置

Set rngC = Range("C2:C100")
For Each cell In rngC
         .
         .
Set rngE = Range("H2:H100")
For Each cell In rngE
         .

两个For循环可以组合成一个，从这一行开始：

For Each cell In Range("C2:C100, H2:H100")

---

到底是什么不起作用？此外，删除on error resume next通常有助于调试，因为它将隐藏任何错误的实际来源…您将答案从MsgBox设置为answerABC，但在If语句中检查answerBICL。这是打字错误吗？您必须确保所有范围都符合预期的工作簿/工作表。每当您有RangeCells、Cells时，它将使用**Active工作簿/工作表中的范围和单元格。您需要像wBook.wSheet.CellsRows.Count、B.EndxlUp.Row`这样做，否则它将从activebook/sheet中获取最后一行。如果你想这样，那就请直截了当。请注意，Rows.Count不一定需要sheet/book引用，因为所有工作表的引用都是相同的。Include选项显式作为每个代码模块的第一行。当您试图在代码中使用未声明的变量时，它会立即告诉您，并直接指向@EganWolf提到的未定义的answerBICL。@EganWolf很抱歉，answerBICL是一个打字错误！这就是正在发生的事情。如果我打开了多个excel工作簿，它会找到正确的工作表，按要求复制，但会给我消息！我真的在拔头发，但什么都没做！它正在处理工作簿中的所有工作表，无论是否找到该值。每个被处理的工作表都会将xyz重置为零，这是在找到值之后发生的。我将告诉您我的困境，我得到一个文件，其中B列的值类似于ABC12345。我正在寻找查找条件，以便在单元格B2中查找值ABC。如果有，则继续该过程，如果没有，则在末尾给出声明的消息。。设置rFound=wSheet.Cells.FindWhat:=ABC，After:=wSheet.Cells1，1，LookIn:=xlFormulas，LookAt:=xlPart，SearchOrder:=xlByRows，SearchDirection:=xlNext，MatchCase:=truel我已经编辑并共享了最终代码，但仍然给我同样的问题！我知道这是一个非常糟糕的代码，但最终我想要的是它的工作！令人惊叹的如果你已经让它工作，请点击检查接受答案，和/或向上投票…我已经编辑并分享了我的最终代码，仍然给我相同的问题！我知道这是一个非常糟糕的代码，但最终我想要的是它的工作！

For Each cell In Range("C2:C100, H2:H100")