پرسش ایجاد کپی از همه شیتها و تغییر نام آنها به صورت همزمان ؟

[bigman]

سلام
من با کد زیر از همه شیتهای یک فایل کپی ایجاد میکنم و یک پیشوند ثابت به ابتدای همه شیتهای جدید اضافه میکنم

Sub CreateNewWorkSheets()

    Dim ws As Worksheet
    Dim wsNew As Worksheet
    Dim wsColl As Collection
    
    Set wsColl = New Collection
    For Each ws In Worksheets
        wsColl.Add ws
    Next
    
    For Each ws In wsColl
        Set wsNew = Worksheets.Add(before:=ws)
        wsNew.Name = ws.Name & "شماره"
    Next
    
End Sub

مشکلی که این کد داره اینه که شیت جدید ایجاد شده "خالی " است و میخوام محتویات شیت مربوطه در داخل شیت جدید کپی بشه .
مثل شکل زیر :
قبل از اجرا :

بعد از اجرا :

سوال دوم میشه رنگ شیتهای جدید مثل عکس دوم به یک رنگ خاص تغییر پیدا کنه ؟؟

[M_ExceL]

با سلام،
از کد ذیل استفاده کنید :

Sub CreateNewWorkSheets()
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Copy after:=ws
        ActiveSheet.Name = ws.Name & "شماره"
        ActiveSheet.Tab.Color = 255
    Next
End Sub