ایجاد کتاب کار برای کاربرگ های فردی در اکسل

Question

دامودار دارای یک کتاب کار است که شامل تعداد زیادی کاربرگ می باشد. او می‌خواهد برای هر کاربرگ کتاب‌های جداگانه ایجاد کند، اما نام کتاب کار بر اساس یک سلول (A7) در کاربرگ که در کتاب کار جدید ذخیره می‌شود، باشد. دامودار می‌داند که می‌تواند یک «حرکت یا کپی» از کاربرگ‌های جداگانه انجام دهد تا آنها را در کتاب‌های کاری جدید وارد کند، اما به دلیل تعداد زیاد کاربرگ‌هایی که با آن سروکار دارد، به دنبال چیزی قوی‌تر است.

جدا کردن کاربرگ‌ها در کتاب‌های کاری جداگانه با استفاده از ماکرو نسبتاً آسان است. موارد زیر تنها یک ماکرو ممکن است. از هر کاربرگ عبور می کند و یک کتاب کار کاملاً جدید برای هر یک از آن کاربرگ ها ایجاد می کند.

Sub SaveEachWks1()
    Dim wkb As Workbook
    Dim wSource As Workbook
    Dim wks As Worksheet
    Dim sPath As String
    Dim sFilename As String

    Location to store the files. Adjust as needed.
    sPath = "C:MyPath"

     Make sure process isnt disturbed
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Set wSource = ActiveWorkbook

    For Each wks In wSource.Worksheets
         Get the filename
        sFilename = wks.Range("A7").Text

         Comment out the following if A7 contains a filename extention
        sFilename = sFilename & ".xlsx"

        Copy the worksheet to a new workbook
        wks.Copy

        Define that workbook
        Set wkb = ActiveWorkbook

         Save the workbook with path and name, then close
        wkb.SaveAs Filename:=sPath & sFilename
        wkb.Close
    Next wks

     Again allow disturbances
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

توجه داشته باشید که ماکرو متغیر sFilename را برابر با ویژگی Text برای سلول A7 قرار می دهد. این فقط در صورتی انجام می شود که سلول حاوی فرمولی باشد که نام فایل را تولید می کند. اگر نام سلول A7 از قبل دارای پسوند نام فایل باشد، باید خطی را که پسوند نام فایل را به sFilename اضافه می کند، نظر دهید.

هنگامی که ماکرو را اجرا می کنید، یک کتاب کار برای هر کاربرگ در کتاب کار انتخابی شما ایجاد می شود. هیچ چیز در کتاب کار اصلی مختل نمی شود. همچنین توجه داشته باشید که ماکرو کمی بدیهی است. به عنوان مثال، بررسی نمی کند که آیا نام فایل در سلول A7 معتبر است یا نه، و همچنین بررسی نمی کند که آیا یک کتاب کار با آن نام فایل از قبل وجود دارد یا خیر. کد برای رسیدگی به چنین شرایطی، با این حال، می تواند به ماکرو اضافه شود. در اینجا یک مثال از یک ماکرو قوی تر است که این مشکلات احتمالی را بررسی می کند:

Sub SaveEachWks2()
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim w As Long
    Dim n As Integer
    Dim sPath As String
    Dim sExt As String
    Dim sName As String
    Dim sFile As String

    Const INVALID = "<>:""/|?*"
    Const INSTEAD = "~"
    Const MAXLEN = 250

    Set WB = ActiveWorkbook
    With Application
        save new workbooks in the active workbooks folder
        sPath = WB.Path & .PathSeparator
        sExt = IIf(.DefaultSaveFormat = xlWorkbookDefault, ".xlsx", ".xls")
        For Each WS In WB.Worksheets
            WS.Activate
            view each worksheet
            DoEvents
            .ScreenUpdating = False

            cell with new workbooks name
            With Range("A7")
                w = .Columns.ColumnWidth
                make it fit .Text
                .Columns.AutoFit
                sName = Trim(.Text)
                restore original width
                .Columns.ColumnWidth = w
            End With
            use worksheets name if necessary
            If sName = "" Then sName = WS.Name

            ensure valid workbook name
            For n = 1 To Len(INVALID)
                sName = Replace(sName, Mid(INVALID, n, 1), INSTEAD, 1)
            Next n
            sFile = sPath & sName & sExt

            check length with margin for duplicate name
            n = Len(sFile) - MAXLEN
            If n > 0 Then
                sName = Left(sName, Len(sName) - n)
                sFile = sPath & sName & sExt
            End If
            n = 1

            check for file with same name
            Do Until Dir(sFile) = ""
                n = n + 1
                sFile = sPath & sName & " (" & n & ")" & sExt
            Loop

            copy worksheet to new workbook, then save and close
            WS.Copy
            ActiveWorkbook.SaveAs Filename:=sFile
            ActiveWorkbook.Close
            .ScreenUpdating = True
        Next WS
    End With
    WBs last worksheet will remain active
    MsgBox WB.Worksheets.Count _
        & " worksheets were copied as new workbooks in folder " _
        & vbNewLine & sPath
End Sub

این ماکرو، اگر یک کاراکتر نامعتبر در نام فایل پیدا کند، آن کاراکتر را با یک tilde (~) جایگزین می‌کند، بنابراین هیچ خطایی در ذخیره کتاب کار جدید رخ نمی‌دهد. همچنین کتاب‌های کار جدید را در همان Workbook که کتاب اصلی در آن ذخیره شده است، ذخیره می‌کند.

در نهایت، همیشه می توانید مسیری را طی کنید که به یک افزونه تکیه کنید تا کار را برای شما انجام دهد. یکی از افزونه‌های پیشنهادی مشترکین برای نیازهای Damodars، ASAP Utilities است که می‌توانید آن را در این مکان پیدا کنید:

https://www.asap-utilities.com