انتقال هم زمان چندین فایل اکسل به یک فایل مرجع

[~M*E*H*D*I~]

درود
پیرو تاپیک جدا کردن شیت های فایل به صورت فایل های مجزای اکسل چطور میشه تعداد زیادی فایل رو به صورت همزمان وارد یک فایل کرد برای این کار کافیست کد زیر رو در یک module بنویسید:

Sub ImportDistrictsfiles()

Application.ScreenUpdating = false
 Application.DisplayAlerts = false 
Application.Calculation = xlManualDim 
Tlr As Long, Alr As Long, u As String, v As String, w As Worksheet, x As Integer, y As Integer, z As Variant
z = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls,Excel files (*.xlsm),*.xlsm,Excel files (*.xlsx),*.xlsx", MultiSelect:=True)
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
On Error Resume Next
For x = 1 To UBound(z)
If Err.Number = 13 Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You did not select any workbooks." & vbCrLf & _
"Click OK to exit this macro.", 48, "Import action cancelled."
On Error GoTo 0
Err.Clear
Exit Sub
End If
Workbooks.Open (z(x))
For Each w In ActiveWorkbook.Worksheets
v = w.Name
Err.Clear
On Error Resume Next
u = ThisWorkbook.Worksheets(v).Name
If Err.Number <> 0 Then
With ThisWorkbook
.Worksheets.Add(After:=.Sheets(.Sheets.Count)).Name = v
End With
End If
On Error GoTo 0
Err.Clear
If Application.CountA(w.Columns(1)) = 1 Then
Alr = 2
Else
Alr = w.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
If Application.CountA(ThisWorkbook.Worksheets(v).Cells) <> 0 Then
Tlr = ThisWorkbook.Worksheets(v).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Else
Tlr = 1
End If
w.Rows("1:" & Alr).Copy ThisWorkbook.Worksheets(v).Cells(Tlr, 1)
Next w
ActiveWorkbook.Close False
Next x
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "The import is complete.", 64, "Done !!"
End Sub 

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.