用VBA选择上一个或下一个工作表
作者：未知 文章来源：未知 点击数： 更新时间： 8:59:30
&&& 如果需要用VBA代码在Excel工作簿中选择下一个或上一个工作表，可以使用下面的代码。
& Sub DownSheet()&&&&& Dim i As Integer&&&&& i = Worksheets.Count&&&&& If ActiveSheet.Index & i Then&&&&&&&&& Worksheets(ActiveSheet.Index + 1).Activate&&&&& Else&&&&&&&&& Worksheets(1).Activate&&&&& End If& End Sub& Sub UpSheet()&&&&& Dim i As Integer&&&&& i = Worksheets.Count&&&&& If ActiveSheet.Index & 1 Then&&&&&&&&& Worksheets(ActiveSheet.Index - 1).Activate&&&&& Else&&&&&&&&& Worksheets(i).Activate&&&&& End If& End Sub
&&& 说明：DownSheet过程选择下一个工作表，第3、12行代码使用Worksheets对象的Count属性取得工作表的数目，第4行到第7行代码根据Index属性判断活动工作表是否是工作簿中的最后一张工作表。如果活动工作表不是最后一张工作表则激活活动工作表的下一张工作表，否则激活第一张工作表。&&& UpSheet过程选择上一个工作表，第13行到第16行代码根据Index属性判断活动工作表是否是工作簿中的第一张工作表。如果活动工作表不是第一张工作表则激活活动工作表的上一张工作表，否则激活最后一张工作表。
上一篇文章：
下一篇文章：
其他网友还在看：
　网友评论：（评论内容只代表网友观点，与本站立场无关！）
::发表评论::
评论内容：
请遵守及中华人民共和国其他各项有关法律法规。
严禁发表危害国家安全、损害国家利益、破坏民族团结、破坏国家宗教政策、破坏社会稳定、侮辱、诽谤、教唆、淫秽等内容的评论 。
用户需对自己在使用本站服务过程中的行为承担法律责任（直接或间接导致的）。
评论需要审核通过后才可见，本站管理员有权保留或删除评论内容。
评论内容只代表网友个人观点，与本网站立场无关。
&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
Excel技巧天地 E-mail:2014年9月 其他开发语言大版内专家分月排行榜第二2012年3月 其他开发语言大版内专家分月排行榜第二2010年5月 其他开发语言大版内专家分月排行榜第二
2013年5月 其他开发语言大版内专家分月排行榜第三
2014年9月 其他开发语言大版内专家分月排行榜第二2012年3月 其他开发语言大版内专家分月排行榜第二2010年5月 其他开发语言大版内专家分月排行榜第二
2013年5月 其他开发语言大版内专家分月排行榜第三
2014年9月 其他开发语言大版内专家分月排行榜第二2012年3月 其他开发语言大版内专家分月排行榜第二2010年5月 其他开发语言大版内专家分月排行榜第二
2013年5月 其他开发语言大版内专家分月排行榜第三
本帖子已过去太久远了，不再提供回复功能。如何快速的合并多个 Excel 工作簿成为一个工作簿？ - 知乎628被浏览246018分享邀请回答/question/.html19362 条评论分享收藏感谢收起6326 条评论分享收藏感谢收起查看更多回答Excel如何用VBA自动合并同目录下的多个excel工作簿文件
Excel如何用VBA自动合并同目录下的多个excel工作簿文件
小美聊办公
在excel的使用过程中，有时候我们需要将同目录下有着相同标题的多个excel工作簿合并到一个excel工作簿中，比如下面这种情况，5个年级的学生名单合并到一个表里面去。常用的做法是手工打开每个文件，复制粘贴到学生名单汇总一个表里去。这里介绍一个偷懒的方法，用VBA代码自动合并。代码分4段，第1段是主代码，后面3段是自定义函数。建议把代码复制粘贴到个人工作簿的模块里，方便调用。打开学生名单汇总.xlsx ALT+F8运行该代码。以下是具体代码，复制粘贴Sub 同目录下合并多个excel工作簿()'On Error Resume Next '// 发生错误，自动执行下一句，就是忽略错误Application.ScreenUpdating = False '//关闭屏幕刷新Application.DisplayAlerts = False '//关闭系统提示t = Timer '//开始时间Set SH0 = ActiveWorkbook.Worksheets(1)SH0.Cells.Clear '//清空保存区域，全部数据第一行是标题行，且只占一行，无合并单元格ARR = FileAllArr(ActiveWorkbook.Path, &*.xlsx&, ActiveWorkbook.Name, False) '//详见函数说明SHName = &sheet1& '//要求所有工作簿内需要统计的工作表名称相同，For i = 0 To UBound(ARR)Str_coon = &Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=& & ARR(i) '//Excel2007' Str_coon = &Provider=Microsoft.JET.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';data source=& & & ARR(I) '//OFFICE2003，根据情况选择StrSQL = &SELECT *,'& & GetPathFromFileName(ARR(i), False) & &' AS 来自工作簿 FROM [& & SHName & &$]& '//SQL语句自己发挥吧，这里是精髓。IROW = SH0.Range(&A1048576&).End(3).Row + 1If IROW &= 2 ThenIROW = 1Crr = GET_SQLCoon(StrSQL, Str_coon, True) '//第一次，带上标题ElseCrr = GET_SQLCoon(StrSQL, Str_coon, False)End IfSH0.Range(&A& & IROW).Resize(UBound(Crr, 1) + 1, UBound(Crr, 2) + 1) = Crr '//粘贴查询结果NextApplication.ScreenUpdating = True '//恢复屏幕刷新Application.DisplayAlerts = True '//恢复系统提示MsgBox &汇总用时：& & Format(Timer - t, &#0.0000&) & & 秒&, , &北极狐提示!!& '//提示所用时间End SubRem 下面是为方便整理的自定义函数，上面的代码执行必不可少哟！！'*******************************************************************************************************'功能：
查找指定文件夹含子文件夹内所有文件名或文件夹名（含路径）'函数名： FileAllArr'参数1：
需查找的文件夹名 不含最后的&\&'参数2：
FileFilter
需要过滤的文件名，可省略，默认为：[*.*]'参数3：
剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name'参数4：
是否只要文件夹名，可省略，默认为：FALSE'返回值： 一个字符型的数组'使用方法：arr = FileAllArr(ThisWorkbook.Path, &*.xls&, ThisWorkbook.Name,false)'*******************************************************************************************************Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = &*.*&, Optional ByVal Liwai As String = &&, Optional ByVal Files As Boolean = False) As String()
Set Dic = CreateObject(&Scripting.Dictionary&)
'创建一个字典对象
Set Did = CreateObject(&Scripting.Dictionary&)
Dic.Add (Filename & &\&), &&
Do While i & Dic.Count
Ke = Dic.keys
'开始遍历字典
MyName = Dir(Ke(i), vbDirectory)
'查找目录
Do While MyName && &&
If MyName && &.& And MyName && &..& Then
If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then
'如果是次级目录
Dic.Add (Ke(i) & MyName & &\&), && '就往字典中添加这个次级目录名作为一个条目
MyName = Dir
'继续遍历寻找
Dim arrx() As String
If Files = True Then
'//是否只输出文件夹名
For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
ReDim Preserve arrx(i)
If Ke && Filename & &\& Then '//自身文件夹除外
arrx(i) = Ke
FileAllArr = arrx
For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
Do While MyFileName && &&
If MyFileName && Liwai Then '排除例外文件
ReDim Preserve arrx(i)
arrx(i) = Ke & MyFileName
MyFileName = Dir
FileAllArr = arrx
End IfEnd Function'****************************************************************'*'****************************************************************************************************'函数:
GetPathFromFileName
根据全路径获得文件名'参数1：strFullPath 完整路径'参数2：kzm true 返回字符串含扩展名'参数3：strSplitor 各级文件夹分隔符'作用: 从完整路径获取返回: 文件名(true带扩展名)'使用方法: msgbox GetPathFromFileName(&C:\windows\text.txt&,true)'*'****************************************************************************************************Public Function GetPathFromFileName(ByVal strFullPath As String, Optional ByVal kzm As Boolean = True, Optional ByVal strSplitor As String = &\&) As String
Dim FileName1 As String
Dim FNAME As String FileName1 = Left$(strFullPath, InStrRev(strFullPath, strSplitor, , vbTextCompare)) FileName1 = Replace(strFullPath, FileName1, &&)
If kzm = False Then
GetPathFromFileName = Left(FileName1, InStr(FileName1, &.&) - 1)
GetPathFromFileName = FileName1
End IfEnd Function'*'****************************************************************************************************'*****************************************************************************************'函数名：
GET_SQLCoon'函数功能： 获得指定SQL的查询结果，自定义连接字符串，可以连接各种数据库'返回值：
返回一个二维数组'参数1：
SQL查询语句'参数2：
Str_coon 字符类型
数据库连接语句'参数3：
是否输出标题，默认带有标题'使用方法： Arr = GET_SQLCoon(StrSQL,Str_coon,true)'
Arr(0,1) '//数组第一行为标题行，从i=1 开始是数据'
Sh2.Range(&A2&).Resize(UBound(ARR, 1) + 1, UBound(ARR, 2) + 1) = ARR'*****************************************************************************************Public Function GET_SQLCoon(ByVal StrSQL As String, ByVal Str_coon As String, Optional Biaoti As Boolean = True) As Variant()On Error Resume Next
' 改变错误处理的方式。Dim Cn, RS Err.Clear Set Cn = CreateObject(&Adodb.Connection&) '//新建一个ADO连接 Set RS = CreateObject(&adodb.recordset&)
Cn.Open Str_coon
RS.Open StrSQL, Cn, 1, 3
If RS.RecordCount & 0 Then '//如果找到数据
If Biaoti = True Then
ReDim ARR(0 To RS.RecordCount, 0 To RS.Fields.Count - 1)
For a = 0 To RS.Fields.Count - 1 '//导入标题
ARR(0, a) = RS.Fields(a).Name
For i = 0 To RS.RecordCount - 1 '//导入数据
For a = 0 To RS.Fields.Count - 1
ARR(i + 1, a) = RS.Fields(a).Value
RS.MoveNext
ReDim ARR(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1)
For i = 0 To RS.RecordCount - 1 '//导入数据
For a = 0 To RS.Fields.Count - 1
ARR(i, a) = RS.Fields(a).Value
RS.MoveNext
Else '//如果没有找到数据
ReDim ARR(1, 1)
ARR(0, 0) = &&
End If GET_SQLCoon = ARR Cn.Close '//关闭ADO连接 Set RS = Nothing Set Cn = Nothing '//释放内存End Function'*****************************************************************************************
本文仅代表作者观点，不代表百度立场。系作者授权百家号发表，未经许可不得转载。
小美聊办公
百家号 最近更新：
简介: 办公一族，分享自己的办公知识技巧
作者最新文章