请问: excel vba, 打开多个xls文件, 搜索字符串，写入另一个sheet的问题

Question

目的: 打开一个"办公文具"的sheet,搜索其中"@yahoo"的字符串(包括@yahoo.com, @yahoo.cn等),将此单元格的内容复制到一个新的sheet里.直到整个"办公文具"sheet搜索完毕.Sub 宏1()
'
' 宏1 Macro
''
    Sheets("办公文具").Select
    Sheets.Add.Name = "bak13"
    
    Sheets("办公文具").Select
    Range("B1").Select
    Cells.Find(What:="@yahoo", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Activate
    'Range("B13").Select
    'Selection.Copy
    'Sheets("bak2").Select
    'ActiveSheet.Paste
    'Range.Next
    'Sheets("办公文具").Select
    'Application.CutCopyMode = False
    'Cells.FindNext(After:=ActiveCell).Activate'While Cells.Text <> Null    Selection.Copy
    Sheets("bak13").Select
    
    'ActiveSheet.ActiveCell.
        ActiveSheet.Paste
    ActiveCell.Next     <----问题出在这里
    Sheets("办公文具").Select
    Application.CutCopyMode = False
    Cells.FindNext(After:=ActiveCell).Activate
'Cells.Find.
'Wend
 End Sub另外还有一个问题:如果某个目录下有多个xls文件(包括"办公文具.xls"文件),每个文件里都有一个sheet,情况类似"办公文具sheet".
请问: 如何能够轮流打开全部的xls文件,将当中的sheet中符合"@yahoo"条件的单元格力的内容, 复制到"bak13" 这一个sheet里?

Answer 1

Sub FindStrings() 
Dim path As String 
path = "I:\wentrip\promotion\data\2007data" 
Filename = Dir(path & "\*.xls") 
Filename = path & "\" & Filename 
Do While Filename  <> "I:\wentrip\promotion\data\2007data"        Dim firstCell, nextCell, stringToFind As String 
       Dim nCursor As Integer 
        
       stringToFind = "@yahoo" 
       nCursor = 1 
       nextCell = "" 
        
       'Sheet1.Select 
       Sheets("办公文具").Select 
       Range("b1").Select 
       Range("b1").Activate 
       Set firstCell = Cells.Find(What:=stringToFind, After:=ActiveCell, LookIn:=xlFormulas, LookAt _ 
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ 
        False) 
       If firstCell Is Nothing Then 
           MsgBox "Search Value Not Found.", vbExclamation 
       Else 
           Sheets("bak11").Cells(1, nCursor).Value = firstCell 
           nCursor = nCursor + 1 
            
           Do While firstCell.Address  <> nextCell 
               If nextCell = "" Then 
                  nextCell = firstCell.Address 
               End If 
               nextCell = Cells.FindNext(After:=Range(nextCell)).Address 
               If firstCell.Address  <> nextCell Then 
                 
                  'Sheets("2").Cells(1, nCursor).Value = Range(nextCell).Value 
                    Sheets("bak11").Cells(nCursor, 1).Value = Range(nextCell).Value 
         
                  nCursor = nCursor + 1 
               End If 
           Loop 
       End If 
  
  Filename = Dir  <----- 这里出错！！！！！ 
  Filename = path & "\" & Filename 
Loop    End Sub 另外， Sheets("办公文具")，这个名称也是变动的，也许叫做“机械设备”，或者别的。这应该如何写？sheets(1)代替?