開いているすべてのExcelブックでキーワード検索を実行するVBA

Question

私はExcel VBAマクロコードを多数作成しており、多くの成果を上げています。私はABC12345のような開いているExcelブックの1つで利用可能なキーワードを検索したいという問題にぶつかりました。そして、 "ABC"がセルB2に見つかったら条件を満たしたい。

私のコードは、これまで：

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 

任意の提案をいただければ幸いです。

ありがとうございます！

Answer 1

あなたはこれを使って、サーチ線を短くすることができます

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

これはでコマンド

With Columns("A") 
     .Replace ";", "" 
     .Replace ":", "" 
     .Replace ",", "" 
     .Replace "(", "" 
     .Replace ")", "" 
     .Replace "{", "" 
       . 
       . 
       . 
    End 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 

を

簡略化する別の場所：

あなたは各非空のセルの横にテキスト「会社」を入れて2つの範囲の内容をチェックし

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

がループの場合2 は、この行で始まる一つに組み合わせることができます

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

Answer 2

あなたの問題は、内側forループを時間内に終了しないことです。 XYZfoundを何も設定していないすべてのシートを処理した後、外側を終了します。

このことを一度だけ見つけたら、「exit for」を数行移動して、ループを終了してブック内の次のシートを処理してください。

Answer 3

@nwhaughtとは別に、If xFound = 1 Then Exit Forに問題があります。 xFoundはBooleanと宣言されており、値1（1）を設定しても、実際の値はTrueです。今、VBA Trueは1と等しくなく、Ifの条件は常にFalseです。 VBAのTrueの値は-1ですが、これは必要ありません。ブール値をチェックするだけで十分ですので、別のブール値と比較する必要はありません。If xFound Then Exit Forを使用してください。