پرفروش ترين
برترين
آخرين محصولات فروشگاه
فایل الکترونیکی آموزش اکسل پیشرفته ۲۰۱۰
آموزش ایجاد فایل چندکاربره با سطح دسترسی مشخص
نمایش نتایج: از شماره 1 تا 4 , از مجموع 4

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

  1. #1


    آخرین بازدید
    تاریخ عضویت
    January 2014
    نوشته ها
    800
    امتیاز
    1684
    سپاس
    594
    سپاس شده
    1,259 در 438 پست
    تعیین سطح نشده است

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

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


  2.  

  3. #2


    آخرین بازدید
    تاریخ عضویت
    January 2014
    نوشته ها
    800
    امتیاز
    1684
    سپاس
    594
    سپاس شده
    1,259 در 438 پست
    تعیین سطح نشده است

    کد:
    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
    این کد رو پیدا کردم

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


  4. #3


    آخرین بازدید
    یک دقیقه پیش
    تاریخ عضویت
    September 2013
    محل سکونت
    بچه محل آقا امام رضا
    نوشته ها
    4,491
    امتیاز
    12379
    سپاس
    8,959
    سپاس شده
    10,650 در 3,761 پست
    سطح اکسل
    100.00 %

    نقل قول نوشته اصلی توسط 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 ذخيره ميكنه. حالا شما بايد يا اين متغير رو مقدار بدين يا ريفرنس بدين به يك سلول كه مقدار رو از اونجا برداره


  5. #4


    آخرین بازدید
    تاریخ عضویت
    January 2014
    نوشته ها
    800
    امتیاز
    1684
    سپاس
    594
    سپاس شده
    1,259 در 438 پست
    تعیین سطح نشده است

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



اطلاعات موضوع

کاربرانی که در حال مشاهده این موضوع هستند

در حال حاضر 1 کاربر در حال مشاهده این موضوع است. (0 کاربران و 1 مهمان ها)

موضوعات مشابه

  1. پاسخ ها: 6
    آخرين نوشته: 2016/05/24, 11:54

بازدید کنندگان با جستجو های زیر این صفحه را پیدا کرده اند

ذخیره یک شیت site:exceliran.com

کلمات کلیدی این موضوع

علاقه مندی ها (Bookmarks)

مجوز های ارسال و ویرایش

  • شما نمیتوانید موضوع جدیدی ارسال کنید
  • شما امکان ارسال پاسخ را ندارید
  • شما نمیتوانید فایل پیوست کنید.
  • شما نمیتوانید پست های خود را ویرایش کنید
  •  
  • BB code ها فعال هستند
  • شکلک ها فعال هستند
  • کد [IMG] فعال است
  • کد [VIDEO] فعال است
  • کد HTML غیر فعال است