在所有打开的Excel工作簿VBA中执行关键字search
我一直在研究很多Excel VBAmacros代码，并取得了很多成就。 我遇到了一个问题，我希望执行一个关键字的search可能在一个打开的Excel工作簿，如 – ABC12345，我希望如果在单元格B2中find“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 任何build议将不胜感激。
谢谢！
你可以使用这个缩短search行：
Columns("A").Replace ";", "" Columns("A").Replace ":", "" Columns("A").Replace ",", "" Columns("A").Replace "(", "" Columns("A").Replace ")", "" Columns("A").Replace "{", "" . . . .
这是使用With命令的一个很好的理由的例子
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
另一个地方来简化：
两个范围内容检查您将文本“Company”放在每个非空单元旁边
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")
除了@nwhaught所说的， If xFound = 1 Then Exit For有一个问题。 你的xFound被声明为Boolean ，尽pipe你设置了1的值，实际的值是True 。 现在，对于VBA True不等于1 ，你的If条件总是False 。 True在VBA中的值是-1 ，但是你不需要这个。 只要使用If xFound Then Exit For ，因为检查一个布尔值是足够的，所以不需要将它与另一个布尔值进行比较。
你的问题是，你不能及时退出你的内在循环。 在处理完所有的工作表后，退出外部处理，即将XYZfound设置为无。
如果您只需要一次find这个东西，然后将您的“出口”移动几行，并在处理工作簿中的下一张表之前终止循环。