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

Collapse
X
 
  • زمان
  • نمایش
حذف همه
new posts
  • ali.b

    • 2014/01/12
    • 798

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

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

  • ali.b

    • 2014/01/12
    • 798

    #2
    کد:
    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

      • 2013/09/20
      • 4537
      • 100.00

      #3
      نوشته اصلی توسط absorkhi
      کد:
      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

        • 2014/01/12
        • 798

        #4
        این کد رو به صورت زیر خلاصه کردم
        کد:
        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

        کامنت

        چند لحظه..