search所有表单中的值

我在这里提供的代码能够searchSheet1，然后将search到的值（包含值的整行）复制到新工作表中，然后在searchstring后重命名工作表。

但是现在我正试图在excel中search所有表格而不是一张表格，这次我还需要包含相关行的表头。

例如，如果我search苹果，macros将search苹果的所有工作表，例如，如果在sheet7上find苹果，它将被复制到一个名为“苹果”的新工作表与相关的标题。

但是，例如，如果在sheet7和sheet8上同时存在apple，则两者都将被复制到新的表格名称“Apple”中，但这两个标题也必须复制到新表格中。

我如何开始工作呢？ 我知道我必须找出工作表的数量并循环，但之后我应该包括什么？

Dim strSearch Dim rg As Range, rgF As Range Dim i As Integer Dim celltxt As String Dim strSearch2 'Dim x, NumberOfWorksheet As Integer 'to count worksheet for loop Application.ScreenUpdating = False strSearch = Application.InputBox("Please enter the search string") strSearch2 = Replace(strSearch, "*", " ") ' NumberOfWorksheet = ThisWorkbook.Sheets.Count ' For x = 0 To NumberOfWorksheet If Len(strSearch) > 0 Then Worksheets.Add().Name = strSearch2 Set rg = Sheets("Sheet1").Cells(1).CurrentRegion 'Define whole search range here For i = 1 To rg.Rows.Count 'we look rows by rows (to copy row once only) Set rgF = rg.Rows(i).Find(strSearch, , xlValues, xlWhole) If Not rgF Is Nothing Then rg.Rows(i).Copy Sheets(strSearch2).Range("A60000").End(xlUp).Offset(1, 0) Set rgF = Nothing End If Next i 'Next x Application.ScreenUpdating = True End If 

Answer 1

它在Excel 2007上工作过：

 Sub sof20312498SearchCopy() Dim i As Long, nRowsAddePerSheet As Long, nRows As Long, _ nRowsMax As Long, nSheets As Long Dim strSearch, strSearch2 Dim rg As Range, rgF As Range Dim wks ' 'Dim x, NumberOfWorksheet As Integer 'to count worksheet for loop Dim x ' strSearch = Application.InputBox("Please enter the search string") strSearch2 = Replace(strSearch, "*", "") If Len(strSearch2) <= 0 Then MsgBox "Abandon: Search string must not be empty." Exit Sub End If Application.ScreenUpdating = False nSheets = Sheets.Count nRowsMax = ActiveSheet.Rows.Count For x = 1 To nSheets ' ' get the worksheet, if nonexistent, add it: ' On Error Resume Next Set wks = Worksheets(strSearch2) If (Err) Then Set wks = Worksheets.Add(After:=Sheets(Sheets.Count)) wks.Name = strSearch2 Err.Clear End If On Error GoTo 0 ' ' Define whole search range here: ' 'Set rg = Sheets("Sheet1").Cells(1).CurrentRegion ' Sheets(x).Activate Set rg = ActiveSheet.Cells(1).CurrentRegion ' ' we look rows by rows (to copy row once only): ' nRows = rg.Rows.Count nRowsAddePerSheet = 0 For i = 1 To nRows Set rgF = rg.Rows(i).Find(strSearch, , xlValues, xlWhole) ' ' if found, copy the source row as the last row of the destination Sheet: ' If Not rgF Is Nothing Then ' ' copy header if required, Row(1) is assumed as header: ' If (nRowsAddePerSheet <= 0) Then If (i <> 1) Then rg.Rows(1).Copy wks.Range("A" & nRowsMax).End(xlUp).Offset(1, 0) End If End If ' rg.Rows(i).Copy wks.Range("A" & nRowsMax).End(xlUp).Offset(1, 0) nRowsAddePerSheet = nRowsAddePerSheet + 1 End If Next Next Set rgF = Nothing Set rg = Nothing Set wks = Nothing Application.ScreenUpdating = True End Sub 

对于searchstring“ Apple ”， Sheet1和Sheet2包含整个单词：

工作表Sheet1

Sheet2中

苹果 – 这是张苹果：