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

[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

[ali.b]

طبق نکته ای که جناب اقای بحرانی گفتن من ی توضیحی در مورد این کد بدم که با این کد شما در قسمت

Sheets(Array("MyData1", "MyData2", "MyData2", "MyData3", _
        "MyData4", "MyData5")).Copy

نام شیت های مورد نظرتون رو که میخواین جداگانه ذخیره بشن رو وارد میکنینن. دقت کنید که شیت ها کاملا جدا و در فایل دیگه ای هستن پس مواظب باشین اگه لینک دارن باید همراه با منبع در نظر بگرین

در قسمت زیر هم تنظیمات مربوط به نحوه ذخیره شدن و نحوه انتخاب نام هر فایل هست که به دلخواه میتونین تغییر بدین

Sheets("Cover Sheet").Select        
        sDataOutputName = Sheets("CalcSheet").Range("N9").Value & "\" & Sheets("CalcSheet").Range("B2").Value
         
         '       Save it with the NewName and in the same directory as original
        ActiveWorkbook.SaveCopyAs sDataOutputName & " MyNewDataWorkbook - Data Sheet.xlsx"
        ActiveWorkbook.Close SaveChanges:=False

هرجا توضیح خوسات من در خدمتم

[ali.b]

این هم ی کد خیلی ساده تر که همین کار رو انجام میده و جایی که تغییر رنگ دادم برای گرفتم نام فایل و محل ذخیره هست

Sub TwoSheetsAndYourOut()    Dim NewName As String
    Dim nm As Name
    Dim ws As Worksheet
  
        Sheets(Array("1", "2", "3")).Copy
        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
      [COLOR=#800080]  ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & Sheet1.Range("a1") & ".xlsx"[/COLOR]
        ActiveWorkbook.Close SaveChanges:=False
End Sub

[ali.b]

این دگه خیلی ساده کردم

Sub sep_sheet()
Sheets(Array("sheet name")).Copy
    ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & Sheet1.Range("a1") & ".xlsx"
        ActiveWorkbook.Close SaveChanges:=False
End Sub

[ali.b]

ی سوال به جای اینکه نام شیت ها رو اینجا بنویسم؟ راهی داره که جور دیگه انجام داد
یعنی اسم شیت ممکنه حرف ی تهش داشته باشه و دردسر باشه

[COLOR=#333333]Sheets(Array("1", "2", "3")).Copy[/COLOR]

[علی فاطمی]

ی سوال به جای اینکه نام شیت ها رو اینجا بنویسم؟ راهی داره که جور دیگه انجام داد
یعنی اسم شیت ممکنه حرف ی تهش داشته باشه و دردسر باشه

[COLOR=#333333]Sheets(Array("1", "2", "3")).Copy[/COLOR]

با سلام ، اگر از index شیتها استفاده کنین مطمئنا بهتره.

[aabbasi4790]

سلام یه سئوال خدمت دوستان من میخوام تعداد متغییر شیت رو ، که با رنگ خاص از هم تفکیک شدن و قابل تشخیص هستند ، به صورت هر رنگ یک فایل اکسل جداگانه ، خروجی بگیرم لطفا راهنمایی کنید

[iranweld]

با سلام

با کد ذیل هر شیت فایل موجود بصورت یک فایل اکسل در مسیر فایل جاری ذخیره میگردد

Sub Sheet_SaveAs()

  Dim wb As Workbook
  
  For Each Sheet In Worksheets
  
  xx = Sheet.Name
  
  Sheet.Copy
  
  Set wb = ActiveWorkbook
  
  With wb
  
    .SaveAs ThisWorkbook.Path & "\" & xx & ".xlsx"
    
    .Close
        
  End With
  
  Next
  
End Sub 

[aabbasi4790]

خب حالا اگه بخوایم شیت 1 و 2 با هم تویه فایل
و شیت 3 و 4 و 5 و 6 با هم تویه فایل دیگه ذخیره بشه
کد رو به چه صورت باید تغییر بدیم؟
یه سوال دیگه
اگه من tab color شیتهای 1 و 2 رو سبز و شیتهای 3 و 4 و 5 و 6 رو مشکی کنم
آیا کدی هست که بر اساس رنگ ، شیتهای همرنگ رو تو فایل مستقل و مجزا ذخیره کنه
تاکیدم بر اساس رنگ ، به علت متغییر بودن تعداد و نام شیتهاست