首页 Excel VBA 复制工作表(合并工作簿)

Excel VBA 复制工作表(合并工作簿)

举报
开通vip

Excel VBA 复制工作表(合并工作簿)Excel VBA 复制工作表(合并工作簿) Excel VBA 复制工作表(合并工作簿) Sub 复制工作表() Dim MyObject As Object Dim strPath As String, strFileName As String, strMyName As String Dim shtSheet As Worksheet, strShtName As String Dim intCount As Integer, intShtCount As Integer, i As Integ...

Excel VBA 复制工作表(合并工作簿)
Excel VBA 复制工作表(合并工作簿) Excel VBA 复制工作表(合并工作簿) Sub 复制工作表() Dim MyObject As Object Dim strPath As String, strFileName As String, strMyName As String Dim shtSheet As Worksheet, strShtName As String Dim intCount As Integer, intShtCount As Integer, i As Integer Application.ScreenUpdating = False strPath = ThisWorkbook.Path strMyName = ThisWorkbook.Name intShtCount = ThisWorkbook.Sheets.Count With Application.FileSearch .NewSearch .LookIn = strPath .SearchSubFolders = False .Filename = ".xls" .FileType = msoFileTypeOfficeFiles If .Execute() > 0 Then intCount = .FoundFiles.Count For i = 1 To intCount strFileName = Replace(.FoundFiles(i), strPath & "\", "") If strFileName <> strMyName Then Set MyObject = GetObject(strPath & "/" & strFileName) '下面进行复制工作 For Each shtSheet In MyObject.Worksheets strShtName = shtSheet.Name If MyObject.Sheets(strShtName).UsedRange.Count > 1 Then MyObject.Sheets(strShtName).Copy After:=ThisWorkbook.Sheets(intShtCount) intShtCount = intShtCount + 1 '重新命名 strShtName = Replace(strFileName, ".xls", "_") & strShtName ThisWorkbook.Sheets(intShtCount).Name = strShtName ThisWorkbook.Sheets("目录").Cells(i + 1, 1) = strShtName End If Next shtSheet End If Next i Else MsgBox "没有找到符合指定文件,请修改参数后重新搜索~" End If End With ThisWorkbook.Sheets("目录").Select Application.ScreenUpdating = True End Sub Sub 复制工作表_2() Dim MyObject As Object Dim strPath As String, strFileName As String, strMyName As String Dim shtSheet As Worksheet, strShtName As String Dim intCount As Integer, intShtCount As Integer, i As Integer Application.ScreenUpdating = False strPath = ThisWorkbook.Path strMyName = ThisWorkbook.Name intShtCount = ThisWorkbook.Sheets.Count With Application.FileSearch .NewSearch .LookIn = strPath .SearchSubFolders = False .Filename = ".xls" .FileType = msoFileTypeOfficeFiles If .Execute() > 0 Then intCount = .FoundFiles.Count For i = 1 To intCount strFileName = Replace(.FoundFiles(i), strPath & "\", "") If strFileName <> strMyName Then 'Workbooks.Open Filename:=strPath & "/" & strFileName Set MyObject = GetObject(strPath & "/" & strFileName) '下面进行复制工作 For Each shtSheet In Workbooks(strFileName).Worksheets strShtName = shtSheet.Name If Workbooks(strFileName).Sheets(strShtName).UsedRange.Count > 1 Then Workbooks(strFileName).Sheets(strShtName).Copy After:=ThisWorkbook.Sheets(intShtCount) intShtCount = intShtCount + 1 '重新命名 strShtName = Replace(strFileName, ".xls", "_") & strShtName ThisWorkbook.Sheets(intShtCount).Name = strShtName ThisWorkbook.Sheets("目录").Cells(i + 1, 1) = strShtName End If Next shtSheet 'Workbooks(strFileName).Close End If Next i Else MsgBox "没有找到符合指定文件,请修改参数后重新搜索~" End If End With ThisWorkbook.Sheets("目录").Select Application.ScreenUpdating = True End Sub
本文档为【Excel VBA 复制工作表&#40;合并工作簿&#41;】,请使用软件OFFICE或WPS软件打开。作品中的文字与图均可以修改和编辑, 图片更改请在作品中右键图片并更换,文字修改请直接点击文字进行修改,也可以新增和删除文档中的内容。
该文档来自用户分享,如有侵权行为请发邮件ishare@vip.sina.com联系网站客服,我们会及时删除。
[版权声明] 本站所有资料为用户分享产生,若发现您的权利被侵害,请联系客服邮件isharekefu@iask.cn,我们尽快处理。
本作品所展示的图片、画像、字体、音乐的版权可能需版权方额外授权,请谨慎使用。
网站提供的党政主题相关内容(国旗、国徽、党徽..)目的在于配合国家政策宣传,仅限个人学习分享使用,禁止用于任何广告和商用目的。
下载需要: 免费 已有0 人下载
最新资料
资料动态
专题动态
is_842972
暂无简介~
格式:doc
大小:21KB
软件:Word
页数:4
分类:互联网
上传时间:2017-11-25
浏览量:124