5,140
社区成员
发帖
与我相关
我的任务
分享请问: 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里?
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里?
...全文
请发表友善的回复…
发表回复
rialibaba 2008-04-18
- 打赏
- 举报
是编程实现。情况还比较复杂
除了逗号，分号，中文，英文，空格，/, 句号, 还有无空格等。
例如 abc@hotmail.com.abc@163.comabc@yahoo.sg / abc@yahoo.com.sg
目标是将这4个邮件地址分成
abc@hotmail.com
abc@163.com
abc@yahoo.sg
abc@yahoo.com.sg
除了逗号，分号，中文，英文，空格，/, 句号, 还有无空格等。
例如 abc@hotmail.com.abc@163.comabc@yahoo.sg / abc@yahoo.com.sg
目标是将这4个邮件地址分成
abc@hotmail.com
abc@163.com
abc@yahoo.sg
abc@yahoo.com.sg
zabaglione 2008-04-17
- 打赏
- 举报
分开保存的话，你要用编程实现吗？
在data->text to column中可以按照;来分割保存到单个cell中的功能
你试试看，如果还不行，明天我来试试看写程序
在data->text to column中可以按照;来分割保存到单个cell中的功能
你试试看，如果还不行，明天我来试试看写程序
rialibaba 2008-04-16
- 打赏
- 举报
另外，如果该单元格里有多个email地址，应该如何处理？
例如，单元格里内容是：“ abc@yahoo.com; efg@yahoo.cn xyz@163.net 或者 abc@msn.com”（即有中文，有分号，有逗号，有空格）。如何把以上4个邮件都单独分开，并单独保存在 sheet（“bak11”）的单元格里 (每个单元格只保存一个email) .
例如，单元格里内容是：“ abc@yahoo.com; efg@yahoo.cn xyz@163.net 或者 abc@msn.com”（即有中文，有分号，有逗号，有空格）。如何把以上4个邮件都单独分开，并单独保存在 sheet（“bak11”）的单元格里 (每个单元格只保存一个email) .
rialibaba 2008-04-16
- 打赏
- 举报
If firstCell Is Nothing Then
MsgBox "Search Value Not Found.", vbExclamation
Else
Sheets("bak11").Cells(1, nCursor).Value = firstCell <--- 这里出错,运行时错误'9',下标越界
MsgBox "Search Value Not Found.", vbExclamation
Else
Sheets("bak11").Cells(1, nCursor).Value = firstCell <--- 这里出错,运行时错误'9',下标越界
zabaglione 2008-04-15
- 打赏
- 举报
Filename = Dir <----- 这里出错！！！！！
这个问题，是因为
Do While Filename <> "I:\wentrip\promotion\data\2007data"
这个地方你把在地址后面加一个符号就可以了
"I:\wentrip\promotion\data\2007data" → "I:\wentrip\promotion\data\2007data\"
就可以了。
这个问题，是因为
Do While Filename <> "I:\wentrip\promotion\data\2007data"
这个地方你把在地址后面加一个符号就可以了
"I:\wentrip\promotion\data\2007data" → "I:\wentrip\promotion\data\2007data\"
就可以了。
zabaglione 2008-04-15
- 打赏
- 举报
这应该如何写？sheets(1)代替?
如果是变动的，就用sheets(1)来代替了。
剩下的那个
Filename = Dir <----- 这里出错！！！！！
我来试试看哦。
如果是变动的，就用sheets(1)来代替了。
剩下的那个
Filename = Dir <----- 这里出错！！！！！
我来试试看哦。
rialibaba 2008-04-14
- 打赏
- 举报
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)代替?
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)代替?
rialibaba 2008-04-14
- 打赏
- 举报
我改了程序这样可以了,
'Sheets("2").Cells(1, nCursor).Value = Range(nextCell).Value
Sheets("2").Cells(nCursor, 1).Value = Range(nextCell).Value
rialibaba 2008-04-14
- 打赏
- 举报
会不会版本问题？我的是excel2000
rialibaba 2008-04-14
- 打赏
- 举报
我原来的代码问题出在这里,可以粘贴的,但粘贴完后,不能下移光标.
ActiveSheet.Paste
ActiveCell.Next <----问题出在这里
ActiveSheet.Paste
ActiveCell.Next <----问题出在这里
rialibaba 2008-04-14
- 打赏
- 举报
有sheet2的
zabaglione 2008-04-14
- 打赏
- 举报
我这里可以的啊。。。是不是sheet2没有？
zabaglione 2008-04-14
- 打赏
- 举报
我这里可以通过的。是不是sheet2的名字不对？或者没有sheet2?
rialibaba 2008-04-14
- 打赏
- 举报
不行啊.
运行时错误1004
应用程序或对象定义错误
Sheet2.Cells(1, nCursor).Value = Range(nextCell).Value
运行时错误1004
应用程序或对象定义错误
Sheet2.Cells(1, nCursor).Value = Range(nextCell).Value
zabaglione 2008-04-14
- 打赏
- 举报
>请问: 如何能够轮流打开全部的xls文件,将当中的sheet中符合"@yahoo"条件的单元格力的内容, 复制到"bak13" 这一>个sheet里?
这个应该不是难事，就是你把所有的xls放到一个目录里面
如下代码
这个应该不是难事，就是你把所有的xls放到一个目录里面
如下代码
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
zabaglione 2008-04-14
- 打赏
- 举报
你好，我基本上写了一个程序可以实现你说的功能，不过和你目前的代码有点区别
请参照：
下面代码完成的功能，就是在sheet1中查找@yahoo,然后copy到sheet2中.测试过了可以使用
请参照：
下面代码完成的功能，就是在sheet1中查找@yahoo,然后copy到sheet2中.测试过了可以使用
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
