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

目的: 打开一个"办公文具"的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里?

 

--------------------

你好，我基本上写了一个程序可以实现你说的功能，不过和你目前的代码有点区别
请参照：
下面代码完成的功能，就是在sheet1中查找@yahoo,然后copy到sheet2中.测试过了可以使用

VBScript code

Sub FindStrings()       Dim firstCell, nextCell, stringToFind As String       Dim nCursor As Integer              stringToFind = "@yahoo"       nCursor = 1       nextCell = ""              Sheet1.Select       Range("A1").Select       Range("A1").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           Sheet2.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                  Sheet2.Cells(1, nCursor).Value = Range(nextCell).Value                  nCursor = nCursor + 1               End If           Loop       End If   End Sub-----------------------

>请问: 如何能够轮流打开全部的xls文件,将当中的sheet中符合"@yahoo"条件的单元格力的内容, 复制到"bak13" 这一>个sheet里?
这个应该不是难事，就是你把所有的xls放到一个目录里面
如下代码

VBScript code 
Dim path As String path = "d:/work" FileName = Dir(path & "/*.xls") FileName = path & "/" & FileName Do While FileName  <> "d:/work/"     ......     FileName = Dir      FileName = path & "/" & FileName Loop
-----------
未完：
http://topic.csdn.net/u/20080414/12/37f8af2d-9b74-495a-b14f-24b6e3f9496f.html