جداسازی شیت های موردنظر

[ali.b]

Sub CreateDataSheet()    
    Dim ws As Worksheet
    Dim sDataOutputName As String


    With Application
        .Cursor = xlWait
        .StatusBar = "Saving DataSheet..."
        .ScreenUpdating = False
         
         '       Copy specific sheets
         '       *SET THE SHEET NAMES TO COPY BELOW*
         '       Array("Sheet Name", "Another sheet name", "And Another"))
         '       Sheet names go inside quotes, seperated by commas
        On Error GoTo ErrCatcher
        Sheets(Array("1", "2", "3")).Copy
        On Error GoTo 0
         
         '       Paste sheets as values
         '       Remove External Links, Hperlinks and hard-code formulas
         '       Make sure A1 is selected on all sheets
        For Each ws In ActiveWorkbook.Worksheets
            ws.Cells.Copy
            ws.[A1].PasteSpecial Paste:=xlValues
            ws.Cells.Hyperlinks.Delete
            Application.CutCopyMode = False
            Cells(1, 1).Select
            ws.Activate
        Next ws
        Cells(1, 1).Select
         
         '       Remove named ranges
        RemNamedRanges
        
        Sheets("1").Select
        
        sDataOutputName = Sheets("1").Range("N1").Value & "\" & Sheets("1").Range("B1").Value
         
         '       Save it with the NewName and in the same directory as original
        ActiveWorkbook.SaveCopyAs sDataOutputName & " MyNewDataWorkbook - Data Sheet.xlsx"
        ActiveWorkbook.Close SaveChanges:=False
        
        .Cursor = xlDefault
        .StatusBar = False
        .ScreenUpdating = True
    End With
    Exit Sub
     
ErrCatcher:
    MsgBox "Specified sheets do not exist within this workbook"
End Sub


Sub RemNamedRanges()
     
    Dim nm              As Name
     
    On Error Resume Next
    For Each nm In ActiveWorkbook.Names
        nm.Delete
    Next
    On Error GoTo 0
     
End Sub

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