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

[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
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & Sheet1.Range("a1") & ".xlsx"
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]

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

Sheets(Array("1", "2", "3")).Copy

[علی فاطمی]

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

Sheets(Array("1", "2", "3")).Copy

با سلام ، اگر از 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 رو مشکی کنم
آیا کدی هست که بر اساس رنگ ، شیتهای همرنگ رو تو فایل مستقل و مجزا ذخیره کنه
تاکیدم بر اساس رنگ ، به علت متغییر بودن تعداد و نام شیتهاست