مساعدة فى تعديل كود " الكود يقوم بعمل نسخة من الملف كله انا أريد يحفظ شيت واحد فقط"

[علي الشيخ]

السلام عليكم ورحمة الله وبركاته

اتمنى من الاخوة مساعدتي فى التعديل على الكود الموجود فى المرفق

الكود موجود فى صفحة vendors

invoice

او صفحة

واسم الزر backup archive

الكود من عمل الاخ عبدالله المجرب وهو بيحفظ نسخة للملف باسم رقم الفاتورة مثلا فى فولدر باسم المشروع على البرتيشن دى

انا عاوز الكود بدل ما يحفظ الملف كله يحفظ الشيت بتاع الفاتورة بس وياريت تعرفوني ازاى اغير مسار الحفظ

بالاضافة الله لا يهينكم الى كود يجمع كل الفواتير اللى هيحفظها فى مجلد معين

كان الاخ ابو حنين الله يسعده عملي كود بس ما يضبط معي على اوفيس 2010

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

فهتتحل لو افادني احدكم ازاى اخليه يحفظ الشيت فقط

والملف فى المرفق التالي

http://www.officena.net/ib/index.php?app=core&module=attach&section=attach&attach_id=55945

[علي الشيخ]

اتمنى حد يرد يا اخوان للضرورة وده تانى موضوع ما حد حتى يحاول يساعد

[علي الشيخ]

اتمنى حد يرد يا اخوان للضرورة وده تانى موضوع ما حد حتى يحاول يساعد

[محمد يحياوي]

الاخ الفاضل استعمل هذا الكود في مثالك يعطيك ملف بجنب ملفك بالاسم الذي تختاره و يمكنك ان تختار الورقة التي تريد بالتعديل على الكود انا اخنرت هنا الورقة2

لاحظ الكود في المرفق

نسخة احتياطية من ورقة وحيدة.rar

[علي الشيخ]

الله يسعدك ويعطيك العافية عل مساعدتك

انا بس فى مشكلة بسيطة ان الكود بتاع حضرتك فى كل مره بعمل تنفيذ بيحفظ الشيت فى نفس مجلد الملف وكمان بكتب له الاسم

البرنامج بتاعى هيتم فيه حفظ شيتات كتيره جدا ولمشروعات مختلفة

الكود اللى عندى فى المرفق بتاع او مشاركة بيقسم وكله تمام مشكلتخ انه مش بيحفظ شيت واحد زي بتاع حضرتك

حاولت اجمع الكودين بطريقة ما بس ما قدرت

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

[علي الشيخ]

للرفع

[علي الشيخ]

للرفع

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

السلام عليكم

عدلنا نفس الكود الذي في ملفك

جرب

Sub copy1()

Dim Wo As Workbook

Dim Sh As Worksheet

Dim Ayadah As String, Extension As String, savePathName As String

'''''''''''''''

If Cells(2, 4) = "" Or Cells(2, 5) = "" Then MsgBox "No Name ", vbOKOnly, "Info!": Exit Sub

'   اسم المجلد

Ayadah = Cells(2, 5)

'''''''''''''''''''

'   اسم الملف

Extension = Cells(2, 4) & ".xls"

''''''''''''''''

'   مسار الحفظ

savePathName = "D:\" & Ayadah & "\"

'''''''''''''''''''

'   ورقة النسخ

Set Sh = ActiveSheet

'''''''''''''''''''''

    Sh.Copy

    Set Wo = ActiveWorkbook

    On Error Resume Next

    Application.DisplayAlerts = False

    GetAttr (savePathName)

    Select Case Err.Number

    Case Is = 0

            Application.DisplayAlerts = False

            Wo.SaveCopyAs savePathName & Extension

            MsgBox "Project name exists and invoice saved in!", vbOKOnly, "Info!"


    Case Else

            MkDir savePathName

            Wo.SaveCopyAs savePathName & Extension

            MsgBox "Project name was created and invoice saved in", vbOKOnly, "Info!"

    End Select

    On Error GoTo 0

''''''''''''''''''''''''''

Wo.Close False

Application.DisplayAlerts = True

Set Wo = Nothing

Set Sh = Nothing

End Sub

[علي الشيخ]

الله يكرمك ويعزك استاذ عبدالله ويزيدك علم

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

دعواتي لك فى ظهر العيب وربنا يسعدك

[عبدالله المجرب]

بارك الله فيك استاذنا الفاضل عبدالله باقشير