كود حفظ بصيغة XLSX

[محمد الحضري]

الساده الكرام

بعد التحيه لجميع اعضاء المنتدى

ارجو المساعده فى صياغه كود لحفظ قيم شيت اكسيل مع التنسيقات وتصديرها الى شيت جديد منفصل بصيغة XLSX بدون مايحفظ المعادلات ( يحفظ القيم والتنسيقات فقط ) مع تحديد الخلايا المراد حفظها

مثلا من خلية A1 الى الخلية L50

جزاكم الله الف خير

[أبو إيمان]

فضلا ارفق مثال

[lionheart]

Try this code

Sub Test()
    Dim wb As Workbook, ws As Worksheet, sh As Worksheet, r As Range
    Set ws = ActiveSheet
    Set r = ws.Range("A1:L50")
    Set wb = Application.Workbooks.Add
    With wb
        Set sh = .Worksheets(1)
        r.Copy sh.Range("A1")
        sh.Range(r.Address).Value = sh.Range(r.Address).Value
        Application.DisplayAlerts = False
            .SaveAs ThisWorkbook.Path & "\Output", 51
        Application.DisplayAlerts = True
        .Close 0
    End With
End Sub

 

[محمد الحضري]

جزاكم الله الف خير

الكود شغال ولكن ينقصه الحفظ بالتنسيقات الاساسية للملف الاصل

 

[lionheart]

Are you sure? Did you try the code well

If the code doesn't work well, please attach a file to have a look

[محمد الحضري]

الكود يعمل بشكل جيد وممتاز جداً لكن المشكله الحالية في التنسيقات

الملف الاصلي يوجد فيه تنسيقات معينة تخلتف مقاسات الصفوف والاعمدة

في حال التصدير تكون مقاسات الشيت الجديد القياسات الافتراضية

المطلوب يكون نفس تنسيقات الملف الاصلي

 

[lionheart]

Attach sample of your file

[lionheart]

Try this version

Sub Test()
    Const iFirstRow As Long = 1, iFirstColumn As Long = 1, iLastRow As Long = 20, iLastColumn As Long = 5
    Dim wb As Workbook, ws As Worksheet, r As Range
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        Set ws = ActiveSheet
        Set r = ws.Range(ws.Cells(iFirstRow, iFirstColumn), ws.Cells(iLastRow, iLastColumn))
        Set wb = Workbooks.Add(xlWBATWorksheet)
        With wb
            ws.Copy Before:=.Worksheets(1)
            .Worksheets(2).Delete
            With .Worksheets(1)
                .Range(r.Address).Value = .Range(r.Address).Value
                .Rows(iLastRow + 1 & ":" & .Rows.Count).Delete
                .Columns(iLastColumn + 1).Resize(, .Columns.Count - iLastColumn).Delete
                .Name = ws.Name
            End With
            .SaveAs ThisWorkbook.Path & "\Output", 51
            .Close 0
        End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub

 

Change the first line in the code to suit the range you desire. In my case this range is A1 to E20

[محمد الحضري]

ممتاز جداً

لكن الكود لا يعمل اثناء حماية ورقة العمل يتطلب فتح حماية الشيت

كي يعمل الكود

 

[lionheart]

I will not work on that topic till you attach a file. That's waste of time

[محمد الحضري]

مرفق الملف

test.rar