使用 vba 在多個工作表和工作簿中查找 excel 中的值

Question

我有一個宏，它在多個工作表和工作簿中找到值“a”並替換為值“b”宏循環遍歷文件夾中的文件和子文件夾中的文件並替換它可以找到的所有值。

現在我希望宏在寫入宏的工作表的 E 列中返回文件名，僅當文件中的位置發生更改時（因此，如果 a 被替換為 b，則返回 E 列中的文件名）

但我當前的代碼只返回它運行的第一個工作簿的文件名。

我的代碼從 sub search 開始，它作為輸入 sub()

Sub FindReplaceAcrossMultipleExcelWorkbooksFreeMacro(Path As String)

    Dim CurrentWorkbookName As String
    Dim ExcelCounter As Integer
    Dim ExcelWorkbook As Object
    Dim FindReplaceCounter As Integer
    Dim FindandReplaceWorkbookName As String
    Dim FindandReplaceWorksheetName As String
    Dim LastRow As Integer
    Dim oFile As Object
    Dim oFolder As Object
    Dim oFSO As Object
    Dim Shape As Shape
    Dim ws As Worksheet
    Dim myrange As Range
    Dim look As String

    FindandReplaceWorkbookName = ActiveWorkbook.Name
    FindandReplaceWorksheetName = ActiveSheet.Name
  
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(Path)

    For Each oFile In oFolder.Files              'Loop through every File in Active Workbook's folder path
    
        If InStr(1, oFile.Type, "Microsoft Excel") <> 0 And InStr(1, oFile.Name, FindandReplaceWorkbookName) = 0 And InStr(1, oFile.Name, "~") = 0 Then 'If the File Type contains the phrase Microsoft Excel isn't the current Excel Workbook and is NOT Lock File
            Set ExcelWorkbook = Application.Workbooks.Open(Path & "\" & oFile.Name) 'Open Excel Workbook
            CurrentWorkbookName = ActiveWorkbook.Name 'Name of Active Excel Workbook that was opened
            Application.Workbooks(CurrentWorkbookName).Activate 'Ensure open Excel Workbook is active for future reference using ActiveWorkbook
            Application.ScreenUpdating = False   'Limit screen flashing when Excel Workbooks opened and when Find & Replace is completed
            FindReplaceCounter = 2
            LastRow = Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row in Column A
            Do Until FindReplaceCounter > LastRow 'Complete the Find and Replace for all values in Column A & B
                For Each ws In ActiveWorkbook.Worksheets 'Loop through every Excel Worksheet in Active Excel Workbook

                    Set myrange = ws.UsedRange.Find(what:="ben")
                    If Not myrange Is Nothing Then
                    
                        Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Range("E" & Rows.Count).End(xlUp).Offset(1, 0) = ExcelWorkbook.Name
                        
                    End If
    
                    ws.Cells.Replace what:=Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Cells(FindReplaceCounter, 1).Value, Replacement:=Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Cells(FindReplaceCounter, 2).Value
                
                Next ws
                
                FindReplaceCounter = FindReplaceCounter + 1
                
            Loop
            
            ActiveWorkbook.Save                  'Save Active Excel Workbook
            ActiveWorkbook.Close                 'Close Active Excel Workbook

        End If
        
    Next oFile

    Application.ScreenUpdating = True            'Turn Excel ScreenUpdating back on

    Set ExcelWorkbook = Nothing
    Set oFSO = Nothing
    Set oFolder = Nothing
    Set oFile = Nothing
  
    Exit Sub
  
End Sub


Sub Search()

    FindReplaceAcrossMultipleExcelWorkbooksFreeMacro (Cells(2, 3).Value)

    MsgBox "The Find and Replace has been completed."
 
End Sub

Answer 1

如果我對您的理解正確，也許下面的代碼可以幫助您將其與您的案例進行比較。

Sub test()
Dim rg As Range: Dim wb As Workbook
Dim oFSO: Dim oFolder: Dim oFile
Dim fn As String: Dim sh As Worksheet: Dim cell As Range

Application.ScreenUpdating = False
Set wb = ActiveWorkbook
With wb.Sheets("Sheet1")
Set rg = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
.Range("E:E").ClearContents
End With

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder("D:\test")
For Each oFile In oFolder.Files
fn = oFile.Name
If InStr(fn, "test") Then GoTo nextfile:
    Workbooks.Open oFile
    With ActiveWorkbook
        For Each sh In .Worksheets
            For Each cell In rg
                If Not sh.Cells.Find(cell.Value) Is Nothing Then
                    sh.UsedRange.Replace what:=cell.Value, Replacement:=cell.Offset(0, 1).Value, LookAt:=xlWhole
                wb.Sheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                    fn & " - " & sh.Name & " : value " & cell.Value & " is replaced with " & cell.Offset(0, 1).Value
                End If
            Next
        Next
    .Close SaveChanges:=False
    End With
nextfile:
Next oFile
Application.ScreenUpdating = True
End Sub

要測試代碼，請創建 3 個工作簿：

1. 將第一個 wb 命名為“test.xlsm”，這是代碼所在的 wb。
   在test.xlsm工作表Sheet1中，在A列和B列制作兩個列標題，並命名為：FIND in A1和REPLACE in B1。 在FIND下，將aaa等數據放入A2，bbb放入A3，ccc放入A4。 在REPLACE下，將XXX等數據放入B2，YYY放入B3，ZZZ放入B4。
2. 創建另外兩個工作簿，隨意命名。 在每個 wb 中，將 aaa 和/或 bbb 和/或 ccc 放入您喜歡的任何單元格中。
3. 將 test.xlsm 和其他兩個工作簿放在 D: 驅動器的一個文件夾中，將文件夾命名為“test”。
4. 運行 test.xlsm 中的代碼。 確保其他兩個工作簿已關閉。

代碼中有三個循環。
首先是循環到測試文件夾中的每個文件
第二個是循環到該文件的每張紙
第三個是循環到工作表 Sheet1 test.xlsm 中的每個 FIND/REPLACE 值

在第一個循環中，它打開文件/工作簿（不是 test.xlsm）
然后它循環到打開的 wb 的每張紙
在looped sheet上，循環到sheet1 test.xlsm中FIND/REPLACE下的每條數據，檢查是否在looped sheet中找到循環單元格值，然后執行兩個過程：（A）找到的值被替換為替換值(B) 將test.xlsm的E欄sheet1中的信息寫入

請注意，代碼不會在正在打開的循環工作簿的循環表上寫入信息。 如果找到要替換的值，它只是替換為一個新值。

如果您第二次運行子程序，則test.xlsm 中E 表Sheet1 列中不應有任何信息。