ذخیره شیت های مورد نظر در یک فایل

[ali.b]

با سلام خدمت دوستان عزیزمن همه کدهایی که برای ذخیره شیت ها گذاشتم کمی طولانی هستنحالا میخوام ی کدای داشته باشم که مثلا از فایلی که 10 تاشیت داره شیت های مورد نظرم رو جداگانه در یک فایل و پوشه دیگه ذخیره کنمکسی میتونه ی کد ساده و جمع و جورتر قرار بدهدرضمن من این کد رو میخوام داخل این کد زیز قرار بدم یعنی همزمان این کد اجرا میشه ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:="D:\Archive" & "\" & Range("A3").Value & "\" & Range("B3").Value & "\" & Range("H3").Value & ".xlsx" ActiveWorkbook.Close

[ali.b]

Option Explicit  
Sub TwoSheetsAndYourOut() 
    Dim NewName As String 
    Dim nm As Name 
    Dim ws As Worksheet 
     
    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _ 
    "New sheets will be pasted as values, named ranges removed" _ 
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub 
     
    With Application 
        .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("Copy Me", "Copy Me2")).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
        For Each nm In ActiveWorkbook.Names 
            nm.Delete 
        Next nm 
         
         '       Input box to name new file
        NewName = InputBox("Please Specify the name of your new workbook", "New Copy") 
         
         '       Save it with the NewName and in the same directory as original
        ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls" 
        ActiveWorkbook.Close SaveChanges:=False 
         
        .ScreenUpdating = True 
    End With 
    Exit Sub 
     
ErrCatcher: 
    MsgBox "Specified sheets do not exist within this workbook" 
End Sub

این کد رو پیدا کردم

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

[Amir Ghasemiyan]

Option Explicit  
Sub TwoSheetsAndYourOut() 
    Dim NewName As String 
    Dim nm As Name 
    Dim ws As Worksheet 
     
    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _ 
    "New sheets will be pasted as values, named ranges removed" _ 
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub 
     
    With Application 
        .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("Copy Me", "Copy Me2")).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
        For Each nm In ActiveWorkbook.Names 
            nm.Delete 
        Next nm 
         
         '       Input box to name new file
        NewName = InputBox("Please Specify the name of your new workbook", "New Copy") 
         
         '       Save it with the NewName and in the same directory as original
        ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls" 
        ActiveWorkbook.Close SaveChanges:=False 
         
        .ScreenUpdating = True 
    End With 
    Exit Sub 
     
ErrCatcher: 
    MsgBox "Specified sheets do not exist within this workbook" 
End Sub

این کد رو پیدا کردم

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

نام فايل رو تو متغير NewName ذخيره ميكنه. حالا شما بايد يا اين متغير رو مقدار بدين يا ريفرنس بدين به يك سلول كه مقدار رو از اونجا برداره

[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
        ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & Sheet1.Range("a1") & ".xlsx"
        ActiveWorkbook.Close SaveChanges:=False
End Sub