خلاصه کردن دستور vb

[2009tv]

با سلام و احترام
توسط راهنمایی ها و سایر مطالب مفید شما اساتید توانستم دستور زیر را با کارکردی که عنوان مینمایم بنویسم. این دستور کاری که من می خواهم را بدستی و بطور کامل انجام می دهد اما مایل هستم در زمانی که بر روی دکمه ای که این دستور را اجرا می کند کلیک می کنیم دیگر شیط کپی شده و مراحل انجام را نشان ندهد و کمی سریعتر این فرایند صورت بگیرد اگر امکانش هست دستور زیر را خلاصه تر نمایید.(بخصوص مایلم مراحل انجام کار مخفیانه انجام بگیرد و کمی زیباتر و حرفه ای تر جلوه کند). ممنون از زحمات و کمک های شما اساتید و دوستان گرامی
شرح دستور:
در این دستور اطلاعات یک شیت بصورت داده هایی عادی و متنی در شیط دیگری ذخیره می شوند و سپس فونت و بولد بودن آنها تغییر می کند و سپس سلولهایی که شامل عدد هستند را فرمت جداکننده عدد را برای آنها قرار می دهد و سپس فقط همین شیط را با پسوند عادی xlsx در درایو d و با نام همان شیط ذخیره می کند.

Sub save ()
    Application.DisplayAlerts = False
    Sheet24.Range("A1:F200").Copy
    Sheet25.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:F").Select
    With Selection.font
        .Name = "zar"
        .Size = 12
        .Bold = True
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
        Range("B15,B18,c17,C57,C59,C61,C62,B122,B125,C129,C131,C133,C135,C137,C139,C141,C143,C145,C147,C149,C151,C153,C155,C157,C159,C161,C163,C165,B166,B169" _
        ).Select
    Selection.NumberFormat = "#,##0"
    End With
    Sheet25.Activate
    Dim wb As Workbook
    Dim filename As String
    Set wb = Workbooks.Add
    filename = Sheet25.Name
    ThisWorkbook.ActiveSheet.Copy Before:=wb.Sheets(1)
    wb.SaveAs "D:\ " & filename & ".xlsx"
    Application.DisplayAlerts = True
    ActiveWorkbook.Close
    Sheet23.Select
   
End Sub

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.

[Amir Ghasemiyan]

سلام دوست عزیز
فکر نکنم از این خلاصه تر بشه

Sub save()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Sheet24.Range("A1:F200").Copy
    Sheet25.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    With Columns("A:F").Font
        .Name = "zar"
        .Size = 12
        .Bold = True
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
        Range("B15,B18,c17,C57,C59,C61,C62,B122,B125,C129,C131,C133,C135,C137,C139,C141,C143,C145,C147,C149,C151,C153,C155,C157,C159,C161,C163,C165,B166,B169" _
        ).NumberFormat = "#,##0"
    End With
    Dim wb As Workbook
    Dim filename As String
    Set wb = Workbooks.Add
    filename = Sheet25.Name
    ThisWorkbook.Sheet25.Copy Before:=wb.Sheets(1)
    wb.SaveAs "D:\ " & filename & ".xlsx"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ActiveWorkbook.Close
    Sheet23.Activate
End Sub

فقط بررسی بفرمایید جایی به ارور نخوره

[2009tv]

خیلی ممنون دوست عزیز
عالی بود!
فقط خط زیر به خطا برخورد کرد که مجبور شدم دستور اصلی را جایگزین کنم:

ThisWorkbook.Sheet25.Copy Before:=wb.Sheets(1)

[Amir Ghasemiyan]

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