查看: 1130|回复: 4
阅读权限8UID401293函数0 关最后登录经验1740 点在线时间139 小时VBA0 关分享记录好友技巧0 关相册主题段位0 段金币2869 个积分1743精华0帖子日志注册时间
字典2：学号037
小学5年级, 积分 1743, 距离下一级还需 57 积分
金币2869 个积分1743帖子
就是在EXCEL VBA代码中运行程序。
使当前本EXCEL文件的激活状态失效，激活或选中另一个已经确定打开了的文件。
另一个文件 可能是EXCEL文件，也可能是WORD文件也可能是图片文件 也可能是 PDF文件
举例文件为 “已打开着的文件.PDF”
阅读权限14UID616423函数2 关最后登录经验4565 点在线时间820 小时VBA0 关分享记录好友技巧0 关相册主题段位3 段金币2117 个积分4565精华1帖子日志注册时间
2013数透班班长
高中2年级, 积分 4565, 距离下一级还需 135 积分
金币2117 个积分4565帖子
你直接 这个“已打开着的文件.PDF”激活不就得了，这个一激活，焦点不就自动离开了那个。
阅读权限8UID401293函数0 关最后登录经验1740 点在线时间139 小时VBA0 关分享记录好友技巧0 关相册主题段位0 段金币2869 个积分1743精华0帖子日志注册时间
字典2：学号037
小学5年级, 积分 1743, 距离下一级还需 57 积分
金币2869 个积分1743帖子
不是用这个EXLCEL文件打开的“已打开着的文件.PDF”
而是 当打开EXCEL文件的时候 “已打开着的文件.PDF”就已经打开了。
所以 我需要在EXCEL当中点击某个按钮的时候，能够激活“已打开着的文件.PDF”文件
阅读权限14UID616423函数2 关最后登录经验4565 点在线时间820 小时VBA0 关分享记录好友技巧0 关相册主题段位3 段金币2117 个积分4565精华1帖子日志注册时间
2013数透班班长
高中2年级, 积分 4565, 距离下一级还需 135 积分
金币2117 个积分4565帖子
那你直接把这个按钮的宏指定为激活“已打开着的文件.PDF”不就得了。
阅读权限8UID401293函数0 关最后登录经验1740 点在线时间139 小时VBA0 关分享记录好友技巧0 关相册主题段位0 段金币2869 个积分1743精华0帖子日志注册时间
字典2：学号037
小学5年级, 积分 1743, 距离下一级还需 57 积分
金币2869 个积分1743帖子
代码&&代码如何写？
每周一测编辑
Powered by查看: 1158|回复: 11|
在线时间0 小时经验5 威望0 性别男最后登录注册时间阅读权限10UID2199982积分5帖子精华0分享0
EH新人, 积分 5, 距离下一级还需 15 积分
积分排行3000+帖子精华0微积分0
本帖最后由 jackdog95 于
11:28 编辑
需要在原来的表格中进行内容的变更，有数字也有文字，我希望就是改完一个单元格，该单元格就会自动标识下（变色，变字体等），有没有这样的VBA代码呢？麻烦帮个忙吧，曾经有个人给过我一段，可是用了这段代码，在编辑EXCEL时候就不能够撤销操作（就是撤销键，例如输入了A，然后点一下撤销就变成输入A之前的状态了）了。代码如下：
Private Sub Worksheet_Change(ByVal Target As Range)
Range(Target.Address).Interior.ColorIndex = 35
谢谢大家的帮助，我已经找到了方法，用审阅的方法可以很好的标记更改内容，希望给和我遇到同样问题的人解决问题，呵呵
在线时间1193 小时经验2133 威望0 最后登录注册时间阅读权限70UID655303积分2183帖子精华0分享0
EH铁杆, 积分 2183, 距离下一级还需 1017 积分
积分排行474帖子精华0微积分0
您指的撤销是什么意思呢？
在线时间0 小时经验5 威望0 性别男最后登录注册时间阅读权限10UID2199982积分5帖子精华0分享0
EH新人, 积分 5, 距离下一级还需 15 积分
积分排行3000+帖子精华0微积分0
LIUZHU 发表于
您指的撤销是什么意思呢？
就是撤销键啊，例如输入了A，然后点一下撤销就变成输入A之前的状态了
在线时间1193 小时经验2133 威望0 最后登录注册时间阅读权限70UID655303积分2183帖子精华0分享0
EH铁杆, 积分 2183, 距离下一级还需 1017 积分
积分排行474帖子精华0微积分0
jackdog95 发表于
就是撤销键啊，例如输入了A，然后点一下撤销就变成输入A之前的状态了
你直接把单元格修改成无色，效果不也是一样的
在线时间28242 小时经验39851 威望26 性别男最后登录注册时间阅读权限95UID501055积分42651帖子精华2分享0
141061财富
积分排行3帖子精华2微积分0
设置条件格式吧，使用Worksheet_Change后，Application.Undo就无效了
在线时间1193 小时经验2133 威望0 最后登录注册时间阅读权限70UID655303积分2183帖子精华0分享0
EH铁杆, 积分 2183, 距离下一级还需 1017 积分
积分排行474帖子精华0微积分0
jackdog95 发表于
就是撤销键啊，例如输入了A，然后点一下撤销就变成输入A之前的状态了
或者，你做一个辅助的表格，用来记录每次改变颜色的单元格地址，再做一个撤销按钮，点击一次就从这个辅助表里寻找最近一次的地址，进行恢复
在线时间1193 小时经验2133 威望0 最后登录注册时间阅读权限70UID655303积分2183帖子精华0分享0
EH铁杆, 积分 2183, 距离下一级还需 1017 积分
积分排行474帖子精华0微积分0
您看一下这个效果
11:04 上传
下载次数: 7
13.14 KB, 下载次数: 7
本帖评分记录鲜花
总评分:&鲜花 + 1&
在线时间0 小时经验5 威望0 性别男最后登录注册时间阅读权限10UID2199982积分5帖子精华0分享0
EH新人, 积分 5, 距离下一级还需 15 积分
积分排行3000+帖子精华0微积分0
zhaogang1960 发表于
设置条件格式吧，使用Worksheet_Change后，Application.Undo就无效了
不太明白，我第一次接触VBA，请问条件格式话，我应该怎么弄？
在线时间0 小时经验5 威望0 性别男最后登录注册时间阅读权限10UID2199982积分5帖子精华0分享0
EH新人, 积分 5, 距离下一级还需 15 积分
积分排行3000+帖子精华0微积分0
LIUZHU 发表于
您看一下这个效果
谢谢啊，不过这个撤销只是撤销了表格的颜色标识，内容并没有撤销。还是谢谢您了。
在线时间1193 小时经验2133 威望0 最后登录注册时间阅读权限70UID655303积分2183帖子精华0分享0
EH铁杆, 积分 2183, 距离下一级还需 1017 积分
积分排行474帖子精华0微积分0
jackdog95 发表于
谢谢啊，不过这个撤销只是撤销了表格的颜色标识，内容并没有撤销。还是谢谢您了。
您要撤销内容也可以，加一句代码就OK了
积分≥4700即可申请
最佳管理者
最佳管理者奖章No.4
最佳管理者
最佳管理者奖章No.3
最佳管理者
最佳管理者奖章No.2
最佳管理者
最佳管理者奖章No.1
金牌优秀管理者
金牌优秀管理者勋章No.1
优秀管理者
优秀管理者勋章No.1
金牌优秀会员
金牌优秀会员奖章No.2
金牌优秀会员
金牌优秀会员奖章No.1
优秀会员奖章No.2
优秀会员奖章No.1
转眼间，论坛即将迎来第300万会员的诞生，为庆祝这一特殊时刻，论坛正开展有奖竞猜第300万会员产生时间段的投票活动，参与竞猜将有机会获得图书、财富的奖励。试试你的幸运指数吧！
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&查看: 3338|回复: 18|
在线时间6 小时经验87 威望0 性别男最后登录注册时间阅读权限20UID636814积分90帖子精华0分享0
EH初级, 积分 90, 距离下一级还需 260 积分
积分排行3000+帖子精华0微积分0
这里是一个表中的多条件查询,本人觉得很好用,但唯一不足的是不能在多个表中进行查询
现上传给从多高手讨论下怎么改下代码能在多表中查询，望高手能指导讨论下发表一下
小弟不甚感谢
17:33 上传
下载次数: 343
20.04 KB, 下载次数: 343
猜你喜欢看
在线时间6184 小时经验48759 威望30 性别男最后登录注册时间阅读权限150UID151593积分49159帖子精华3分享2
管理以下版块
143277财富
积分排行1帖子精华3微积分0
请勿重复发帖，很多高手习惯不解答重复帖。
相同格式的数据应该保存在同一个工作表中，以便自由地使用Excel自带的各种强大功能（例如高级筛选和数据透视表）
由于楼主的帖子，影响了别人的帖子。
18:05 上传
[ 本帖最后由 LangQueS 于
18:05 编辑 ]
在线时间6184 小时经验48759 威望30 性别男最后登录注册时间阅读权限150UID151593积分49159帖子精华3分享2
管理以下版块
143277财富
积分排行1帖子精华3微积分0
建议楼主调整数据管理的方式，请参考下帖附件：& & & &
★Excel数据管理的一般规律★& & & &
在线时间3876 小时经验5521 威望0 最后登录注册时间阅读权限95UID658023积分5521帖子精华0分享0
积分排行163帖子精华0微积分0
回复 1楼 wiben 的帖子
可以用迴圈
For each sh in sheets.......Next sh
如果可以，是否可以把代码贴出來让我看，我在繁体系统下看到的中文是乱码，谢谢!![em01]
在线时间7 小时经验25 威望0 性别男最后登录注册时间阅读权限20UID598043积分25帖子精华0分享0
EH初级, 积分 25, 距离下一级还需 325 积分
积分排行3000+帖子精华0微积分0
确实是不错的东西
在线时间280 小时经验597 威望0 性别男最后登录注册时间阅读权限30UID237338积分597帖子精华0分享0
EH中级, 积分 597, 距离下一级还需 503 积分
积分排行1809帖子精华0微积分0
回复 1楼 wiben 的帖子
可以用迴圈
For each sh in sheets.......Next sh
如果可以，是否可以把代码贴出來让我看，我在繁体系统下看到的中文是乱码，谢谢!!
Sub 矩形1_单击()
& & Dim sLast As String
& & Application.ScreenUpdating = False
& & If Sheets(&锻压&).FilterMode = True Then Sheets(&锻压&).ShowAllData
& & Sheets(&查询&).Select
& & Sheets(&查询&).Range(&A5:A65536&).EntireRow.Delete
& & Sheets(&锻压&).Range(&A4&).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
& && && && && && && && && && && && && && && && && &CriteriaRange:=Rows(&2:3&), CopyToRange:=Range(&A5&), Unique:=False
& & sLast = GetLastRow(ActiveSheet.UsedRange)
& & Range(&A& & sLast).Value = &总计：&
& & Range(&B& & sLast).Formula = &=&&共&& & Counta(B6:B& & sLast - 1 & &) & &&条记录&&&
& & ActiveWorkbook.Sheets(&查询&).Cells(4, 4) = &序号从& & Cells(6, 1) & &至& & Cells(sLast - 1, 1) & &号段之间&
& & Application.ScreenUpdating = True
Range(&1:1&).RowHeight = 45
Range(&2:3&).RowHeight = 16
Range(&4:4&).RowHeight = 15
Range(&5:5000&).RowHeight = 15& &
& & MsgBox &程序已经完成搜索！&
Function GetLastRow(sRange As Range) As String
& & GetLastRow = sRange.Row + sRange.Rows.Count
End Function
在线时间3876 小时经验5521 威望0 最后登录注册时间阅读权限95UID658023积分5521帖子精华0分享0
积分排行163帖子精华0微积分0
回复 6楼 gongqiulin 的帖子
谢谢gongqiulin [em07]
楼主，代码修改如下，测试看看!!
但有个问题，如果筛选不到数据，你的代码还是会将标题copy到查询工作表喔!!
Sub 矩形1_单击()
& & Dim sLast, ActSh As String
& & Application.ScreenUpdating = False
& & ActSh = ActiveSheet.Name
& & Sheets(ActSh).Range(&A5:A65536&).EntireRow.Delete
& & For Each sh In Sheets
& && &&&If sh.Name && ActSh Then
& && && && &If Sheets(sh.Name).FilterMode = True Then Sheets(sh.Name).ShowAllData
& && && && && & If Range(&A65536&).End(xlUp).Row = 2 Then
& && && && && && &&&Sheets(sh.Name).Range(&A4&).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
& && && && && && && && &&&CriteriaRange:=Rows(&2:3&), CopyToRange:=Range(&A5&), Unique:=False
& && && && && & Else
& && && && && && &&&Sheets(sh.Name).Range(&A4&).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
& && && && && && && && &&&CriteriaRange:=Rows(&2:3&), CopyToRange:=Range(&A& & [A65536].End(xlUp).Row + 1), Unique:=False
& && && && && & End If
& && && && &End If
& & Next sh
& & sLast = GetLastRow(ActiveSheet.UsedRange)
& & Range(&A& & sLast).Value = &总计：&
& & Range(&B& & sLast).Formula = &=&&共&& & Counta(B6:B& & sLast - 1 & &) & &&条记录&&&
& & ActiveWorkbook.Sheets(ActSh).Cells(4, 4) = &序号从& & Cells(6, 1) & &至& & Cells(sLast - 1, 1) & &号段之间&
& & Application.ScreenUpdating = True
& & Range(&1:1&).RowHeight = 45
& & Range(&2:3&).RowHeight = 16
& & Range(&4:4&).RowHeight = 15
& & Range(&5:5000&).RowHeight = 15
& & MsgBox &程序已经完成搜索！&
Function GetLastRow(sRange As Range) As String
& & GetLastRow = sRange.Row + sRange.Rows.Count
End Function
在线时间6 小时经验87 威望0 性别男最后登录注册时间阅读权限20UID636814积分90帖子精华0分享0
EH初级, 积分 90, 距离下一级还需 260 积分
积分排行3000+帖子精华0微积分0
谢谢mineshine
谢谢mineshine,这个代码的确可以多表查询，但是有一点就是 标题也会显示在查询表中，不知道有什么 好的 办法解决没有
有的 话请一定来发表一下，谢谢
在线时间3876 小时经验5521 威望0 最后登录注册时间阅读权限95UID658023积分5521帖子精华0分享0
积分排行163帖子精华0微积分0
回复 8楼 wiben 的帖子
我加了两句，事後把标题列刪除，我看不出來那段筛选代码该如何改，就先這样做嘍! ::D
Sub 矩形1_单击()
& & Dim ActSh As String
& & Dim sLast, A as Integer
& & Application.ScreenUpdating = False
& & ActSh = ActiveSheet.Name
& & Sheets(ActSh).Range(&A5:A65536&).EntireRow.Delete
& & For Each sh In Sheets
& && &&&If sh.Name && ActSh Then
& && && && &If Sheets(sh.Name).FilterMode = True Then Sheets(sh.Name).ShowAllData
& && && && && & If Range(&A65536&).End(xlUp).Row = 2 Then
& && && && && && &&&Sheets(sh.Name).Range(&A4&).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
& && && && && && && && &&&CriteriaRange:=Rows(&2:3&), CopyToRange:=Range(&A5&), Unique:=False
& && && && && && &&&Sheets(ActSh).Rows(5).Delete& &'刪除第5列标题
& && && && && & Else
& && && && && && &
A = [A65536].End(xlUp).Row& &&&'筛选前最後一列列数
& && && && && && &&&Sheets(sh.Name).Range(&A4&).CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
& && && && && && && && &&&CriteriaRange:=Rows(&2:3&), CopyToRange:=Range(&A& & [A65536].End(xlUp).Row + 1), Unique:=False
& && && && && && &&&Sheets(ActSh).Rows(A + 1).Delete& &'刪除A+1列标题
& && && && && & End If
& && && && &End If
& & Next sh
& & sLast = GetLastRow(ActiveSheet.UsedRange)
& & Range(&A& & sLast).Value = &总计：&
& & Range(&B& & sLast).Formula = &=&&共&& & Counta(B6:B& & sLast - 1 & &) & &&条记录&&&
& & ActiveWorkbook.Sheets(ActSh).Cells(4, 4) = &序号从& & Cells(6, 1) & &至& & Cells(sLast - 1, 1) & &号段之间&
& & Application.ScreenUpdating = True
& & Range(&1:1&).RowHeight = 45
& & Range(&2:3&).RowHeight = 16
& & Range(&4:4&).RowHeight = 15
& & Range(&5:5000&).RowHeight = 15
& & MsgBox &程序已经完成搜索！&
Function GetLastRow(sRange As Range) As String
& & GetLastRow = sRange.Row + sRange.Rows.Count
End Function
[ 本帖最后由 mineshine 于
21:04 编辑 ]
在线时间349 小时经验129 威望0 性别男最后登录注册时间阅读权限20UID570627积分129帖子精华0分享0
EH初级, 积分 129, 距离下一级还需 221 积分
积分排行3000+帖子精华0微积分0
:loveliness: 谢谢分享
积分≥4700即可申请
最佳管理者
最佳管理者奖章No.1
金牌优秀管理者
金牌优秀管理者勋章No.1
金牌优秀管理者
金牌优秀管理者勋章No.2
优秀管理者
优秀管理者勋章No.1
优秀管理者
优秀管理者勋章No.2
金牌优秀会员
金牌优秀会员奖章No.1
优秀会员奖章No.1
转眼间，论坛即将迎来第300万会员的诞生，为庆祝这一特殊时刻，论坛正开展有奖竞猜第300万会员产生时间段的投票活动，参与竞猜将有机会获得图书、财富的奖励。试试你的幸运指数吧！
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&查看: 3391|回复: 24|
在线时间796 小时经验2418 威望1 性别男最后登录注册时间阅读权限70UID111256积分2418帖子精华0分享2
EH铁杆, 积分 2418, 距离下一级还需 782 积分
积分排行423帖子精华0微积分0
大师你好！如何在代码中定义工作表名称？（不是name、表名）谢谢！
我问佛：如何才能如你般睿智？
佛曰：佛是过来人，人是未来佛
在线时间1468 小时经验13754 威望4 性别保密最后登录注册时间阅读权限95UID939601积分13754帖子精华0分享0
积分排行36帖子精华0微积分0
工作表名称不就是name吗？
在线时间2524 小时经验6482 威望9 最后登录注册时间阅读权限100UID523377积分6482帖子精华0分享0
积分排行136帖子精华0微积分0
原帖由 fsydw 于
15:29 发表
大师你好！如何在代码中定义工作表名称？（不是name、表名）谢谢！
直接给该工作表的 Name 属性赋值不就行了吗？
在线时间796 小时经验2418 威望1 性别男最后登录注册时间阅读权限70UID111256积分2418帖子精华0分享2
EH铁杆, 积分 2418, 距离下一级还需 782 积分
积分排行423帖子精华0微积分0
谢谢大师回复！
我是指下面属性窗口的第一行“aaa”如何通过代码定义，不是第九行的“bbb”。谢谢！
(15.91 KB, 下载次数: 8)
15:45 上传
下载次数: 8
我问佛：如何才能如你般睿智？
佛曰：佛是过来人，人是未来佛
在线时间2524 小时经验6482 威望9 最后登录注册时间阅读权限100UID523377积分6482帖子精华0分享0
积分排行136帖子精华0微积分0
原帖由 fsydw 于
15:44 发表
谢谢大师回复！
我是指下面属性窗口的第一行“aaa”如何通过代码定义，不是第九行的“bbb”。谢谢！
据说这种要求只能通过 属性 窗口才能操作！
不过，我好奇的是，楼主为什么要去修改这个属性呢？这些对于使用者没有任何用处呀！
在线时间796 小时经验2418 威望1 性别男最后登录注册时间阅读权限70UID111256积分2418帖子精华0分享2
EH铁杆, 积分 2418, 距离下一级还需 782 积分
积分排行423帖子精华0微积分0
原帖由 lu_zhao_long 于
16:06 发表
据说这种要求只能通过 属性 窗口才能操作！
不过，我好奇的是，楼主为什么要去修改这个属性呢？这些对于使用者没有任何用处呀！
谢谢大师赐教！
1、我的工作表标签名称（name）是规范的，不能修改。
2、我的代码需要：找到同类的工作表，进行批量处理。例如这样定义名称：shname0001、shname0002、shname0003......。这样，我取得工作表名称包括“shname”的工作表，进行批量处理。
3、有其它办法吗？在添加工作表时，定义这特殊标记的工作表？
我问佛：如何才能如你般睿智？
佛曰：佛是过来人，人是未来佛
在线时间2524 小时经验6482 威望9 最后登录注册时间阅读权限100UID523377积分6482帖子精华0分享0
积分排行136帖子精华0微积分0
原帖由 fsydw 于
16:20 发表
谢谢大师赐教！
1、我的工作表标签名称（name）是规范的，不能修改。
2、我的代码需要：找到同类的工作表，进行批量处理。例如这样定义名称：shname0001、shname0002、shname0003......。这样，我取得工作表名称 ...
那你需要修改的就是“bbb”所对应的 Name 属性值，并不是（Name）值！
在线时间796 小时经验2418 威望1 性别男最后登录注册时间阅读权限70UID111256积分2418帖子精华0分享2
EH铁杆, 积分 2418, 距离下一级还需 782 积分
积分排行423帖子精华0微积分0
原帖由 lu_zhao_long 于
16:25 发表
那你需要修改的就是“bbb”所对应的 Name 属性值，并不是（Name）值！
大师你好！我的表中，bbb（name）对应的表名是：流水帐、汇总表、分析表、报表。aaa是我想要通过代码修改的地方。谢谢！
我问佛：如何才能如你般睿智？
佛曰：佛是过来人，人是未来佛
在线时间1468 小时经验13754 威望4 性别保密最后登录注册时间阅读权限95UID939601积分13754帖子精华0分享0
积分排行36帖子精华0微积分0
Workbook.CodeName 属性
返回对象的代码名。String 型，只读。
只在设计模式才能更改
在线时间796 小时经验2418 威望1 性别男最后登录注册时间阅读权限70UID111256积分2418帖子精华0分享2
EH铁杆, 积分 2418, 距离下一级还需 782 积分
积分排行423帖子精华0微积分0
原帖由 cflood 于
16:32 发表
Workbook.CodeName 属性
返回对象的代码名。String 型，只读。
只在设计模式才能更改
谢谢大师赐教！
无法返回codename?语句如下：
Dim str_A As String
str_A = Workbook.CodeName
MsgBox (str_A)
大师：我想得到CodeName的字符串，然后批量处理CodeName字符串中包含特定字符的工作表。谢谢！
19:28 上传
下载次数: 14
5.12 KB, 下载次数: 14
我问佛：如何才能如你般睿智？
佛曰：佛是过来人，人是未来佛
优秀会员奖章No.1
积分≥4700即可申请
最佳会员奖章No.1
金牌优秀会员
金牌优秀会员奖章No.1
转眼间，论坛即将迎来第300万会员的诞生，为庆祝这一特殊时刻，论坛正开展有奖竞猜第300万会员产生时间段的投票活动，参与竞猜将有机会获得图书、财富的奖励。试试你的幸运指数吧！
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&查看: 1744|回复: 4|
在线时间120 小时经验20 威望0 性别保密最后登录注册时间阅读权限20UID907408积分20帖子精华0分享0
EH初级, 积分 20, 距离下一级还需 330 积分
积分排行3000+帖子精华0微积分0
在本论坛找了一段用于工作薄合并的代码，但其中有“Application.FileSearch”的语句，在2007中不能使用。搜索了论坛有关的帖子，但对下面程序如何修改才能在2007下运行还是不得要领。请高手帮忙把下面的代码改为能在2007下运行的。谢谢了。
Private Sub CommandButton1_Click()
& & Dim Twb As Workbook, Wb As Workbook
& & Dim rng As Range
& & Dim t As Integer
& & Application.ScreenUpdating = False
& & Set Twb = ThisWorkbook
& & Cells.ClearContents '清除当前表的内容
& & With Application.FileSearch '查找
& && &&&.LookIn = Twb.Path '范围为此目录下
& && &&&.Filename = &*.xls& '查找所有的xls文件
& && &&&.Execute msoSortByFileName '执行查找过程，并且将查询结果按文件名排序
& & ' With Application.Worksheets.
& && &&&For Each s In .FoundFiles '在每一个查找到的结果里
& && && && &If s && Twb.FullName Then '假如它不是当前工作簿
& && && && && & Set Wb = Workbooks.Open(s) '打开它
& && && && && & Do While t & Sheets.Count '读当前工作薄中的所有的工作表
& && && && && & t = t + 1
& && && && && & Set rng = Range(&a65536&).End(xlUp).Offset(1, 0) '设置变量rng为最后一行的下一行
& && && && && & Wb.Sheets(t).UsedRange.Copy rng '复制新打开的工作簿的第一个工作表的已用区域到rng
& && && && && &
& && && && && & Loop
& && && && && & Wb.Close False ' 不保存就关闭这个打开的工作簿
& && && && && & t = 0
& && && && &End If
& && &&&Next
& & End With
& & Application.ScreenUpdating = True
在线时间53 小时经验837 威望3 性别男最后登录注册时间阅读权限50UID8658积分1437帖子精华2分享0
积分排行739帖子精华2微积分0
FileSearch 物件已從 2007 Microsoft Office 程式中去除(這麼好用的功能也拿掉了，真是給他..00XX)，詳細的說明請參考 說明，在說明中微軟有提示可以使用Dir 函式或 FileSystemObject 類別來搜索檔案，今天就依這個提示來做一個類似Application.FileSearch的功能，可以設定是否搜尋子資料夾，詳細說明請參考程式碼....Dim strArr() As String, rCount As Integer
　
Sub App_FileSearch()
'設定要搜尋檔案的關鍵字
'如果要列出所有檔案請設定為String = &&
Const keyword As String = &*.xls& '搜尋xls檔案
& & 'App_SearchSubFolder(keyword, True) '搜尋包含子資料夾
& & 'App_SearchSubFolder(keyword, False) '搜尋不包含子資料夾
& & Call App_SearchSubFolder(keyword, True)
& & If UBound(strArr) & 0 Then
& && &&&'以超連結的方式列出檔案
& && &&&For i = 0 To UBound(strArr)
& && && && &If strArr(i) && && Then
& && && && && & ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 3, &A&), _
& && && && && && && && &Address:=strArr(i), TextToDisplay:=strArr(i)
& && && && &End If
& && &&&Next i
& & Else
& && &&&MsgBox &未發現檔案&
& & End If
End Sub
　
Function App_SearchSubFolder(keyword As String, rSearchSubFolders As Boolean)
Dim fd As Object
Dim fso As Object
& & Set fso = CreateObject(&Scripting.FileSystemObject&)
& & '開啟Excel內建的資料夾瀏覽方塊
& & Set fd = Application.FileDialog(msoFileDialogFolderPicker)
& & If fd.Show = -1 Then
& && &&&rLookIn = fd.SelectedItems(1)
& & Else
& && &&&MsgBox &未選取資料夾&: Exit Function
& & End If
& & rFilename = Dir$(rLookIn & &\& & keyword)
& & rCount = 0
& & '建立動態陣列
& & ReDim Preserve strArr(rCount)
& & '第一階資料夾
& & Do While rFilename && vbNullString
& && &&&strArr(rCount) = rLookIn & &\& & rFilename
& && &&&rCount = rCount + 1
& && &&&ReDim Preserve strArr(rCount)
& && &&&rFilename = Dir$()
& & Loop
& & If rSearchSubFolders Then& & '判斷是否搜尋子資料夾
& && &&&'搜尋第二階以後的子資料夾
& && &&&Call App_NextSubFolder(fso.GetFolder(rLookIn), keyword)
& & End If
& & Set fd = Nothing
& & Set fso = Nothing
End Function
　
Private Sub App_NextSubFolder(ByRef Folder As Object, _
& && &&&ByRef keyword As String)
Dim SubFolder As Object
& & For Each SubFolder In Folder.SubFolders
& && &&&rFilename = Dir$(SubFolder.Path & &\& & keyword)
& && &&&Do While rFilename && vbNullString
& && && && &strArr(rCount) = SubFolder.Path & &\& & rFilename
& && && && &rCount = rCount + 1
& && && && &ReDim Preserve strArr(rCount)
& && && && &rFilename = Dir$()
& && &&&Loop
& && &&&Call App_NextSubFolder(SubFolder, keyword)
& & Next
End Sub复制代码
天行健 君子以自強不息
screen.width*0.7) {this.resized= this.width=screen.width*0.7; this.alt='Click here to open new window\nCTRL+Mouse wheel to zoom in/out';}" onmouseover="if(this.width>screen.width*0.7) {this.resized= this.width=screen.width*0.7; this.style.cursor='hand'; this.alt='Click here to open new window\nCTRL+Mouse wheel to zoom in/out';}" onclick="if(!this.resized) {} else {window.open('http://chijanzen.net/images/excel-6b.gif');}" onmousewheel="return imgzoom(this);" alt="" />
在线时间120 小时经验20 威望0 性别保密最后登录注册时间阅读权限20UID907408积分20帖子精华0分享0
EH初级, 积分 20, 距离下一级还需 330 积分
积分排行3000+帖子精华0微积分0
谢谢chijanzen。这段代码我也看到了，但就是不知道这么用到我需要的那段代码上，我的水平太菜，如能直接帮我修改一下代码就太谢谢了。
在线时间352 小时经验641 威望0 性别保密最后登录注册时间阅读权限30UID834343积分641帖子精华0分享0
EH中级, 积分 641, 距离下一级还需 459 积分
积分排行1689帖子精华0微积分0
Option Explicit
Private Sub CommandButton1_Click()
& & Dim Twb As Workbook, Wb As Workbook
& & Dim rng As Range
& & Dim t As Integer
& & Application.ScreenUpdating = False
& & Set Twb = ThisWorkbook
& & Cells.ClearContents '清除当前表的内容
& & s = Dir(Twb.Path & &\*.xls&)
& & While s && &&
& && && && &If s && Twb.FullName Then '假如它不是当前工作簿
& && && && && & Set Wb = Workbooks.Open(s) '打开它
& && && && && & Do While t & Sheets.Count '读当前工作薄中的所有的工作表
& && && && && & t = t + 1
& && && && && & Set rng = Range(&a65536&).End(xlUp).Offset(1, 0) '设置变量rng为最后一行的下一行
& && && && && & Wb.Sheets(t).UsedRange.Copy rng '复制新打开的工作簿的第一个工作表的已用区域到rng
& && && && && &
& && && && && & Loop
& && && && && & Wb.Close False ' 不保存就关闭这个打开的工作簿
& && && && && & t = 0
& && && && &End If
& && && && &s = Dir()
& & Application.ScreenUpdating = True
如果不递归搜索下一层的文件夹，那么直接用dir得到的结果应该就可以了。
在线时间120 小时经验20 威望0 性别保密最后登录注册时间阅读权限20UID907408积分20帖子精华0分享0
EH初级, 积分 20, 距离下一级还需 330 积分
积分排行3000+帖子精华0微积分0
非常感谢！[em01] :handshake
转眼间，论坛即将迎来第300万会员的诞生，为庆祝这一特殊时刻，论坛正开展有奖竞猜第300万会员产生时间段的投票活动，参与竞猜将有机会获得图书、财富的奖励。试试你的幸运指数吧！
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&