اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by lionheart,

الردود الموصى بها

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

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

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

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

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

رابط هذا التعليق
شارك

  • أفضل إجابة

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

 

  • Like 2
  • Thanks 1
رابط هذا التعليق
شارك

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

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

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

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

 

رابط هذا التعليق
شارك

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

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information