|
- Sub test()
- Dim r%, i%
- Dim arr(), brr
- Dim wb1 As Workbook
- Dim wb2 As Workbook
- Dim ws As Worksheet
- Dim mypath$, myname$
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- mypath = ThisWorkbook.Path & ""
- myname = Dir(mypath & "*.xls")
- Do While myname <> ""
- If myname <> ThisWorkbook.Name Then
- n = InStrRev(myname, "-")
- If n <> 0 Then
- xm = Left(myname, n - 1)
- If Not d.exists(xm) Then
- Set d(xm) = CreateObject("scripting.dictionary")
- End If
- d(xm)(myname) = ""
- End If
- End If
- myname = Dir
- Loop
- For Each aa In d.keys
- Application.SheetsInNewWorkbook = 1
- Set wb1 = Workbooks.Add
- For Each bb In d(aa).keys
- Set wb2 = GetObject(mypath & bb)
- With wb2
- .Worksheets(1).Copy after:=wb1.Worksheets(wb1.Worksheets.Count)
- .Close False
- End With
- Next
- With wb1
- .Worksheets("sheet1").Delete
- .SaveAs Filename:=mypath & "合并后" & aa, FileFormat:=xlExcel8
- .Close False
- End With
- Next
- Application.ScreenUpdating = True
- MsgBox "数据合并完毕!"
-
- End Sub
复制代码 |
评分
-
2
查看全部评分
-
|