حفظ صفحه من الاكسيل فى شيت جديد

[ابن الملك]

الى كل الاساتذه الكرام فى المنتدى 

فى سؤال معرفش ينفع ولا لا ..........

أنا عندى شيت مكون من أكثر من صفحه جوه ورك بوك واحد

        و السؤال هو هل فى كود يخلينى أختار صفحه معينه يحفظها أكسيل فى ورك بوك تانى

    يعنى الكود يعرف حدود الصفحه لوحده الصفحه مش الشيت يعنى هو شيت واحد لكن فيه كذا صفحه  و يعمل ورك بوك جديد وينسخ نطاق الصفحه المختارة فى الورك بوك الجديد .

مرفق محاوله لكن مش مكتمله ..... منتظر مساعده

Save Page As Excel.rar

تم تعديل يناير 14, 2016 بواسطه ابن الملك

[ياسر خليل أبو البراء]

أخي الكريم ابن الملك

إليك الكود التالي لعله لا يكون المطلوب بشكل كامل كما أردت ولكن قد يكون مفتاح للحل ..حيث أن صفحات ورقة العمل الواحدة تختلف حسب إعدادات الطابعة المنصبة لديك .. ولو غيرت الطابعة ربما تختلف إعدادات الصفحة

عموماً إليك الحل التالي يعتمد على النطاق المحدد ..أي قم بتحديد النطاق أولاً ثم تنفيذ الكود ليتم تصديره إلى مصنف جديد

Sub Copy_Selected_Range_As_New_Workbook()
    Dim a As Range, rng As Range
    
    Application.ScreenUpdating = False
        Set rng = Selection
        ActiveSheet.Copy
        
        If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
        Columns.Hidden = False
        Rows.Hidden = False
        Cells.ClearContents
        
        For Each a In rng.SpecialCells(xlCellTypeVisible).Areas
            Range(a.Address).Value = a.Value
        Next a
        
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\YourFileName.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

 

Export Selected Range To New Workbook YasserKhalil.rar

[حماده سعد الله]

العلامة الكبير أبو البراء كل عام وحضرتك بألف خير وكل أسرة هذا المنتدي المحترم أرجو من كرمك أن تعدل من هذا الكود لتكون الورقة المنسوخةبنفس اسم الورقة المنسوخ منها ويكون الحفظ ب Exel 97 /2003workbook

أرجو ألا أكون أثقلت علي حضرتك

[حماده سعد الله]

هل من مشارك هل  هناك من يعطينا بعضا من وقته أيها العباقرة ومساعدة أخيكم 

[ياسر خليل أبو البراء]

Sub Copy_Selected_Range_As_New_Workbook()
    Dim a As Range, rng As Range
    
    Application.ScreenUpdating = False
        Set rng = Selection
        ActiveSheet.Copy
        
        If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
        Columns.Hidden = False
        Rows.Hidden = False
        Cells.ClearContents
        
        For Each a In rng.SpecialCells(xlCellTypeVisible).Areas
            Range(a.Address).Value = a.Value
        Next a
        
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\YourFileName.xls", FileFormat:=56, CreateBackup:=False
        ActiveWorkbook.Close
    Application.ScreenUpdating = True
End Sub

 

[حماده سعد الله]

مم

[حماده سعد الله]

مازاللت المشكلة قائمة أرجوا المساعدة في التوصل لحل

[حماده سعد الله]

في ١٥‏/١٢‏/٢٠١٦ at 21:09, ياسر خليل أبو البراء said:

Sub Copy_Selected_Range_As_New_Workbook()
    Dim a As Range, rng As Range
    
    Application.ScreenUpdating = False
        Set rng = Selection
        ActiveSheet.Copy
        
        If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
        Columns.Hidden = False
        Rows.Hidden = False
        Cells.ClearContents
        
        For Each a In rng.SpecialCells(xlCellTypeVisible).Areas
            Range(a.Address).Value = a.Value
        Next a
        
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\YourFileName.xls", FileFormat:=56, CreateBackup:=False
        ActiveWorkbook.Close
    Application.ScreenUpdating = True
End Sub

 

الكود لم يحقق المطلوب أخي وأستاذي 

[ياسر خليل أبو البراء]

ارفق ملفك بعد وضع الكود المشار إليه في الملف .. وتوضيح المشكلة بشكل أدق ولو بالصور

[حماده سعد الله]

في ١٥‏/١‏/٢٠١٦ at 10:18, ياسر خليل أبو البراء said:

أخي الكريم ابن الملك

إليك الكود التالي لعله لا يكون المطلوب بشكل كامل كما أردت ولكن قد يكون مفتاح للحل ..حيث أن صفحات ورقة العمل الواحدة تختلف حسب إعدادات الطابعة المنصبة لديك .. ولو غيرت الطابعة ربما تختلف إعدادات الصفحة

عموماً إليك الحل التالي يعتمد على النطاق المحدد ..أي قم بتحديد النطاق أولاً ثم تنفيذ الكود ليتم تصديره إلى مصنف جديد

Sub Copy_Selected_Range_As_New_Workbook()
    Dim a As Range, rng As Range
    
    Application.ScreenUpdating = False
        Set rng = Selection
        ActiveSheet.Copy
        
        If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
        Columns.Hidden = False
        Rows.Hidden = False
        Cells.ClearContents
        
        For Each a In rng.SpecialCells(xlCellTypeVisible).Areas
            Range(a.Address).Value = a.Value
        Next a
        
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\YourFileName.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

 

Export Selected Range To New Workbook YasserKhalil.rar

العلامة الكبير أبو البراء كل عام وحضرتك بألف خير وكل أسرة هذا المنتدي المحترم أرجو من كرمك أن تعدل من هذا الكود لتكون الورقة المنسوخة بنفس اسم الورقة المنسوخ منها ويكون الحفظ بصيغة  Exel 97 /2003workbook وأن تكون في ملف مستقل 

أرجو ألا أكون أثقلت علي حضرتك

[ياسر خليل أبو البراء]

أخي الكريم هذا ما يقوم به الكود بالفعل ..قمت بتجربة الكود مرة أخرى فقام بتصدير الورقة Sheet1 إلى مصنف جديد وبه نفس اسم الورقة المنسوخ منها

فقط تم تغيير السطر الخاص بالحفظ

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\YourFileName.xls", FileFormat:=56, CreateBackup:=False

هذا السطر ليكون التصدير بصيغة 97/2003

[حماده سعد الله]

العلامة الكبير أبو البراء شكرا جزيلا

أصبح الحفظ بصيغة  Exel 97 /2003workbook ولكن ليس في فولدر مستقل 

كما أن الورقة المنسوخة بنفس اسم الورقة المنسوخ منها داخل العمل

ولكن ما أريده أن يصبح الاسم الخارجي للعمل الناتج بنفس الاسم الداخلي للورقة

أرجوأن أكون استطعت توصيل ما أقصده كما أرجوا ألا أكون أثقلت علي حضرتك

وأدعوا الله أن يجعل تعبك وجهدك هذا في ميزان حسناتك

[ياسر خليل أبو البراء]

جرب الكود التالي

Sub Copy_Selected_Range_As_New_Workbook()
    Dim a As Range, rng As Range
    Dim strDir As String

    Application.ScreenUpdating = False
        Set rng = Selection
        ActiveSheet.Copy
    
        If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
        Columns.Hidden = False
        Rows.Hidden = False
        Cells.ClearContents
    
        For Each a In rng.SpecialCells(xlCellTypeVisible).Areas
            Range(a.Address).Value = a.Value
        Next a
    
        strDir = ThisWorkbook.Path & "\Test\"
    
        If Dir(strDir, vbDirectory) = "" Then
            MkDir strDir
        End If
    
        ActiveWorkbook.SaveAs Filename:=strDir & ThisWorkbook.Name & ".xls", FileFormat:=56, CreateBackup:=False
        ActiveWorkbook.Close
    Application.ScreenUpdating = True
End Sub