[حل شده] خلاصه کردن دستور 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]

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