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

[إبراهيم محمد]

بسم الله الرحمن الرحيم 

الاستاذة الافاضل  / اعمدة هذا المنتدي العريق 

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

والمطلوب هو استكمال بعض الاكواد فى الازرار الثلاثه  ومن اهمها زر ترحيل الصفحات الى ملفات منفصله تحمل نفس اسم الصفحه ويتم حفظها فى نفس الفولدر او يتم اختيار مكان حفظ الصفحات  التى سوف يتم تحويلها الى ملفات منفضله 

واعتقد عند فتح الملف سوف تتضح الفكرة افضل 

 وجزاكم الله كل خير على ما تبذلوه من عطاء لخير هذا المنتدى وتعليم روادة 

ترحيل صفحات الى ملفات منفصله.rar

 

[عبدالله باقشير]

السلام عليكم

 

بالنسبة لعمل الزرين تحديد الكل

يكفيك زر CheckBox

واحد لعمل ذلك

 

اضف زر CheckBox

وسميه  CheckSelect

 

واضف الكود ادناه الى الفورم

Private Sub CheckSelect_Click()
With Me.ListBox1
    For i = 0 To .ListCount - 1
        .Selected(i) = Me.CheckSelect.Value
    Next
End With
End Sub
 

في امان الله

[إبراهيم محمد]

استاذنا الحبيب وعالمنا الجليل  الاستاذ الفاضل / عبد الله باقشير 

لكم اسعدني مرورك الكريم على المشاركه ووضع لمسه من لمساتك السحريه التى نتعلم منها كل  يوم 

وان شاء الله ساعمل على تعديل بدل الزرين الاول والثاني  ساستبدلهم بتشيك بوكس  كما تفضلت فى مشاركتك الكريمه 

ويبقى بعد ذلك الجزء الاخر وهو كود الجزء الثالث 

وبارك الله فيك استاذا ومعلمنا الجليل 

[إبراهيم محمد]

مرفق الملف بعد عمل التعديل الذى اقترحه استاذنا ومعلمنا الفاضل  / عبد الله باقشير 

من استبدال  الزر الاول و الثاني  ب تشيك بوكس  يقوم بنفس المهمه 

ترحيل صفحات الى ملفات منفصله1.rar

 

والرجاء المساعدة فى استكمال باقى الاكواد  وجزاكم الله خيرا 

[إبراهيم محمد]

الحمد لله تم التوصل الى هذا الكود  برجاء من الاساتذة الافاضل تقيمه او التعديل عليه 



Private Sub Cmd_action_Click()
With Me.ListBox1
    For i = 0 To .ListCount - 1
        If .Selected(i) = True Then
            On Error Resume Next
            Application.ScreenUpdating = False
            Application.DisplayAlerts = False
            Set newwkbk = Workbooks.Add
            Flname = ThisWorkbook.Sheets(i + 1).Name
            
            ThisWorkbook.Sheets(i + 1).Copy Before:=newwkbk.Sheets(1)
            newwkbk.Sheets("Sheet1").Delete
            newwkbk.Sheets("Sheet2").Delete
            newwkbk.Sheets("Sheet3").Delete
            newwkbk.SaveAs ThisWorkbook.Path & "\" & Flname
            ActiveWorkbook.Close
                            
        End If
    Next
End With
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 MsgBox "Êã ÍÝÙ ÇáÕÝÍÇÊ ÇáãÍÏÏÉ Ýì ãáÝÇÊ ãäÝÕáå "
End Sub

 

 

[إبراهيم محمد]

وهذا هو المرفق بعد اضافه الكود له 

 

ترحيل صفحات الى ملفات منفصله2.rar

 

 

[عبدالله باقشير]

السلام عليكم

 

جرب هذا مختصر

 

يعمل كوبي للورقة في ملف جديد ويحفظها

 

Private Sub Cmd_action_Click()
Dim iPath As String, Sht As String
Dim wo As Workbook
'''''''''''''''''''''''
iPath = ActiveWorkbook.Path & Application.PathSeparator
'''''''''''''''''''''''
With Me.ListBox1
    For i = 0 To .ListCount - 1
        If .Selected(i) = True Then
            Sht = .List(i)
            Worksheets(Sht).Copy
            Set wo = ActiveWorkbook
            '''''''''''''''''''''''''''''''''''''
            '      : حفظ الملف واغلاقه

            With wo
                .SaveAs iPath & Sht
                .Close False
            End With
            '''''''''''''''''''''''''''''''''''''
        End If
    Next
End With
Set wo = Nothing
End Sub
 

في امان الله

[إبراهيم محمد]

ما شاء الله عليك يا استاذنا ومعلمنا 

كود مختصر وينم عن احتراف وتمكن  ان شاء الله سوف اجربه عند عودتي واخبرك بالنتيجه  وكم اتمنى من الله ان اصل ولو  واحد من مئه من علمكم 

فدائما نتعلم منكم وجعلكم الله نورا يهتدى به  ويبارك لكم فيه  

[حمادة عمر]

السلام عليكم

الاستاذ القدير العلامة الخبير / عبدالله باقشير

 

انت الارووووع دائما كعادتك

جعلك الله دائما زادا لنا من العلم وبارك الله فيك

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

[إبراهيم محمد]

ما شاء استاذنا الفاضل وعالمنا الجليل / عبد الله باقشير 

لقد قمت بتجربه الكود وهو يعمل بكفاءة عاليه  بارك الله فيك وجزاك الله خيرا ودائما نتعلم منكم  كل جديد باذن الله تعالى