~M*E*H*D*I~
2014/05/16, 13:14
درود
پیرو تاپیک جدا کردن شیت های فایل به صورت فایل های مجزای اکسل (http://forum.exceliran.com/showthread.php?t=4481) چطور میشه تعداد زیادی فایل رو به صورت همزمان وارد یک فایل کرد برای این کار کافیست کد زیر رو در یک 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)).Nam e = 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).Cell s) <> 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
پیرو تاپیک جدا کردن شیت های فایل به صورت فایل های مجزای اکسل (http://forum.exceliran.com/showthread.php?t=4481) چطور میشه تعداد زیادی فایل رو به صورت همزمان وارد یک فایل کرد برای این کار کافیست کد زیر رو در یک 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)).Nam e = 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).Cell s) <> 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