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

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

قام بنشر

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

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

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

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

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

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

ترحيل صفحات الى ملفات منفصله.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

 

 

قام بنشر

السلام عليكم

 

جرب هذا مختصر

 

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

 

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
 

في امان الله

قام بنشر

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

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

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

قام بنشر

السلام عليكم

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

 

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

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

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

قام بنشر

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

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

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