可以写宏来做,以下是一段代码,用来合并文件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 In 展开
可以写宏来做,以下是一段代码,用来合并文件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 'change by Tony strShtName = "Sheet"&intShtCount ThisWorkbook.Sheets(intShtCount).Name = strShtName ThisWorkbook.Sheets("目录").Cells(i + 1, 1) = strShtName End If Next shtSheet End If Next i Else MsgBox "没有找到符合指定文件，请修改参数后重新搜索！", , "笔锋侠实用工具系列-批量修改文件名 V1.0"End If End With ThisWorkbook.Sheets("目录").Select Application.ScreenUpdating = TrueEnd Sub点击工具->宏->宏 取个名字点创建,复制以上代码,然后把要合并的excel文件和本文件放在一个文件夹,之后运行这个宏,就可以了. 收起
