VBA-合并Excel文件的Sheet到新文件中

1.打开宏文件【xxx.xlsm】点击按钮自动合并

代码：

  1 Option Explicit
  2 
  3 Const MergeFileName As String = "Merged.xlsx"
  4 Const FilePathSeparator As String = "\"
  5 Const Ext_XLSX As String = "xlsx"
  6 Const Cells_COLM_A As String = "A"
  7 Const TempFile_Prefix As String = "~$"
  8 
  9 Sub Test_AutoSelectAndMergeFile()
 10     Dim thisPath As String
 11     
 12     thisPath = ThisWorkbook.Path
 13 '    MsgBox thisPath & " get current path OK"
 14     
 15     Dim fs, objFolder, colFiles
 16     
 17     Rem get file object
 18     Set fs = CreateObject("Scripting.FileSystemObject")
 19     Set objFolder = fs.GetFolder(thisPath)
 20     Set colFiles = objFolder.Files
 21 '    MsgBox thisPath & " = " & colFiles.Count
 22     
 23     Rem create merge file template
 24     Dim mergeTemplate As String
 25     mergeTemplate = thisPath & FilePathSeparator & MergeFileName
 26     If fs.FileExists(mergeTemplate) Then
 27         MsgBox "Merge File is Allreday exists: " & mergeTemplate
 28             
 29     Else
 30         Call CreateMergeFile(mergeTemplate)
 31         
 32     End If
 33     
 34     Dim findex As Integer
 35     Dim objFile
 36     findex = 0
 37     
 38     Dim fnameArr() As String
 39     ReDim fnameArr(0 To colFiles.Count)
 40     
 41     
 42     Rem open the merge template
 43     Dim temp As Workbook
 44     Set temp = Workbooks.Open(mergeTemplate, ReadOnly:=False)
 45     
 46     Rem get every file's name
 47     For Each objFile In objFolder.Files
 48                        
 49         Rem get every file's extension
 50         Dim fname As String
 51         Dim extStr As String
 52         extStr = fs.GetExtensionName(objFile.Path)
 53         fname = objFile.Name
 54        
 55         If Ext_XLSX = extStr And MergeFileName <> fname And InStr(fname, TempFile_Prefix) = 0 Then
 56             
 57             fnameArr(findex) = objFile.Path
 58             findex = findex + 1
 59 '            MsgBox fname & " OK"
 60 '            temp.Sheets("Sheet1").Cells(findex, Cells_COLM_A).Value = objFile.Path
 61 '            Sheets("Sheet1").Cells(findex, Cells_COLM_A).Value = objFile.Path
 62 
 63             
 64             Rem open file and moveorcopy sheets
 65             Workbooks.Open fileName:=fname
 66             Sheets().Copy After:=temp.Sheets(temp.Sheets.Count)
 67             Workbooks(fname).Close
 68             
 69         End If
 70          
 71     Next objFile
 72     
 73     Application.DisplayAlerts = False
 74     temp.Activate
 75     temp.Sheets("Sheet1").Delete
 76     temp.Sheets("Sheet2").Delete
 77     temp.Sheets("Sheet3").Delete
 78     
 79 '    Dim wname As String
 80 '    wname = ThisWorkbook.Name
 81 '    MsgBox wname
 82     Dim i As Integer
 83     
 84     For i = 0 To UBound(fnameArr)
 85     
 86         ThisWorkbook.Sheets("Sheet1").Cells(i + 10, Cells_COLM_A).Value = fnameArr(i)
 87     
 88     Next i
 89     
 90     Set fs = Nothing
 91     
 92 
 93 End Sub
 94 
 95 
 96 Function CreateMergeFile(thisPath As String)
 97 
 98     Dim excelApp, excelWB As Object
 99     
100     Set excelApp = CreateObject("Excel.Application")
101     Set excelWB = excelApp.Workbooks.Add
102     
103     excelWB.SaveAs thisPath
104     
105 '    MsgBox "file Created: " & thisPath
106     
107     excelApp.Quit
108 
109 End Function
ViewCode

 

 

2.通过按钮或事件触发打开目录，选择需要合并的文件

代码：

 1 Option Explicit
 2 
 3 Sub SelectMultiExcelNewMerge()
 4 
 5     Dim thisPath As String
 6     thisPath = ThisWorkbook.Path
 7     Dim mergFileName As String
 8     mergFileName = thisPath & "\Merged2.xlsx"
 9     
10     Dim fs As Object
11     Set fs = CreateObject("Scripting.FileSystemObject")
12     If fs.FileExists(mergFileName) Then
13         MsgBox "Merge File is Allreday exists:" & mergFileName
14         fs.DeleteFile (mergFileName)
15     End If
16 
17     Dim excelApp, excelWB As Object
18     Set excelApp = CreateObject("Excel.Application")
19     Set excelWB = excelApp.Workbooks.Add
20     excelWB.SaveAs mergFileName
21     excelApp.Quit
22     
23     Dim m As Workbook
24     Set m = Workbooks.Open(mergFileName, ReadOnly:=False)
25     
26     Dim FileOpen
27     Dim x As Integer
28     Application.ScreenUpdating = False
29     FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel File(*.xls*),*.xls*", MultiSelect:=True, Title:="MergeFile")
30     x = 1
31     While x <= UBound(FileOpen)
32         Workbooks.Open fileName:=FileOpen(x)
33         Sheets().Copy After:=m.Sheets(m.Sheets.Count)
34         x = x + 1
35     Wend
36     m.Activate
37     m.Sheets("Sheet1").Delete
38     m.Sheets("Sheet2").Delete
39     m.Sheets("Sheet3").Delete
40        
41        
42 ExitHandler:
43     Application.ScreenUpdating = True
44     Exit Sub
45     
46       
47 Errhadler:
48     MsgBox Err.Description
49 End Sub
View Code

 

posted @ 2021-02-25 15:02  Cyber9527  阅读(266)  评论(0)    收藏  举报