|
|
楼主 |
发表于 2018-2-20 18:50
|
显示全部楼层
如何改呀
Sub 分别对应表名合并()
Dim MyPath$, Myname$, sh As Worksheet, m&, d As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path & "\"
If .Show = False Then Exit Sub
MyPath = .SelectedItems(1) & "\"
End With
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
Set d(sh.Name) = sh
sh.UsedRange.Offset(3).Clear
Next
FilePath = Getname(MyPath)
For v = 0 To UBound(FilePath)
Set wb = Workbooks.Open(FilePath(v))
For Each sh In wb.Sheets
If sh.Name <> ThisWorkbook.Name Then
m = m + 1
If d.Exists(sh.Name) Then
If m <= 1 Then
sh.UsedRange.Copy d(sh.Name).[A1]
Else
sh.UsedRange.Offset(0).Copy d(sh.Name).Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End If
End If
Next
wb.Close False
Next
Application.ScreenUpdating = True
End Sub
Function Getname(lj As String)
Dim Myname, Dic, Did, i, T, a, TT, MyfileName
Set Dic = CreateObject("scripting.dictionary")
Set Did = CreateObject("scripting.dictionary")
Dic.Add (lj), ""
i = 0
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 & "\"), ""
End If
End If
Myname = Dir
Loop
i = i + 1
Loop
For Each ke In Dic.keys
MyfileName = Dir(ke & "*.xls*")
Do While MyfileName <> ""
If MyfileName <> ThisWorkbook.Name Then Did.Add (ke & MyfileName), ""
MyfileName = Dir
Loop
Next
Getname = Did.keys
End Function
|
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-2-20 17:55
