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