فرض میکنیم که یک فایل اکسل داریم که حاوی 12 شیت با نام ماههای سال است و می خواهیم هر شیت یه عنوان یک فایل جدید اکسل در محل همان فایل ذخیره شود . خب می توانیم این کار را به صورت دستی انجام دهیم که زمان زیاید لازم دارد و درصد خطا هم بالاست .
فهرست محتوا
فایل جدید اکسل با نام شیتهای موجود در فایل جاری
اگر بخواهیم تمام شیتهای فایلی که در حال کار کردن با آن هستیم به صورت کپی و هر شیت با نام همان شیت کنار فایل فعلی ما ذخیره شود ، کافیست کاهای زیر را انجام دهیم.
- مطمئن شوید که فایل ذخیره شده و مکان آن مشخص است
- مسیر فایل حاوی پوشه فارسی نباشد
- کدهای زیر را در یک ماژول قرار داده و آن را اجرا کنید.
Sub SplitEachWorksheet()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
ws.Copy
Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
ذخیره کردن هر شیت یک فایل دیگر اکسل
کدهای قبلی ، شیتهای فایل جاری را هر کدا را در یک فایل جدید اکسل ذخیره می کرد و نام هر فایل هم از نام همان شیت گرفته می شد .
اما در ادامه کدهایی تقدیم شما می شود که با اجرای آن از کاربر یک فایل اکسل خواسته می شود و شیتهای موجود در آن فایل به صورت فایلهای جدا گانه در پوشه Sheets در کنار همان فایل اکسل ذخیره می شود .
Sub SplitSheetsToFiles()
Dim SourceWorkbook As Workbook
Dim DestinationPath As String
Dim CurrentSheet As Worksheet
Dim NewWorkbook As Workbook
Dim FilePath As String
On Error Resume Next
Set SourceWorkbook = Workbooks.Open(Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", Title:="Select Excel File"))
On Error GoTo 0
If SourceWorkbook Is Nothing Then
Exit Sub
End If
DestinationPath = ThisWorkbook.Path & "\Sheets\"
If Dir(DestinationPath, vbDirectory) = "" Then
MkDir DestinationPath
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In SourceWorkbook.Sheets
ws.Copy
Application.ActiveWorkbook.SaveAs Filename:=DestinationPath & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
SourceWorkbook.Close SaveChanges:=False ' بستن فايل اصلي
MsgBox "تمام شيت‌ها به عنوان فايل‌هاي جداگانه در مسير زير ذخيره شدند:" & vbCrLf & DestinationPath, vbInformation
End Subایجاد Personal Macro و اجرا در تمام فایلها
برای اینکه کدهایی که قرار دادیم در تمام فایلهای اکسل کامپیوتر شما اجرا شود می توانید کدها را در Personal Macro قرار دهید و آیکون آن را در Quick Access Toolbar قرار دهید. که آموزش آن در ویدیو همین پست داده شده است. و هر بار به راحتی با کلیک روی آن تمام شیتها به عنوان یک فایل جدید اکسل به صورت جداگانه ذخیره میشوند.
