مشكلة في كود نقل الملف إلى سطح المكتب

[ابو تميم]

تحية طيبة

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

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

مثال في الملف المرفق

اسم الملف FF واسم الورقة النشطة المراد نقلها إلى سطح المكتب أيضا FF عندما نضغط زر نقل الملف إلى سطح المكتب يتم تكرار الورقة داخل نفس الملف بالاسم FF(2) ثم إذا ضغطنا على الزر مرة أخرى يتم نقل الورقة FF(2) إلى سطح المكتب

أرجو أن يكون السؤال واضحا

شكرا جزيلا لكم وجزاكم الله خيرا

FF.rar

[ابو تميم]

up

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

جرب حذف هذه الاسطر

    For Each Wok In Workbooks

			    If Wok.Name = MyWok Then

					    ActiveSheet.Copy Before:=Workbooks(MyWok).Sheets(1)

					   ' Application.Windows(2).Activate

					    MsgBox ("تم نقل الملف إلى سطح المكتب"), vbMsgBoxRight, ("نقل ")

				  Exit Sub

			    End If

	    Next

[ابو تميم]

شكرا جزيلا أخي ابو احمد

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

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

[الـعيدروس]

مثل ماتفضل اخي عبدالله المجرب

جرب التعديل التالي

علما أنه بيغلق الملفان لانهم بنفس الاسم

Sub outsheet()

On Error Resume Next

MyWok = ActiveSheet.Name & ".xlsb"

MYPATH = Environ("homedrive") & Environ("HOMEPATH") & "\desktop" & "\" & MyWok

	    If Dir(MYPATH) = "" Then

		  Application.DisplayAlerts = False

		    ActiveWorkbook.SaveAs Filename:=MYPATH, FileFormat:=xlExcel12, CreateBackup:=False

		    Application.Windows(2).Activate

		    MsgBox ("تم نقل الملف إلى سطح المكتب")

		    Windows(MyWok).Close

	   Else

	   Application.DisplayAlerts = False

	    If MsgBox(" هذا الملف موجود مسبقا هل تريد إستبداله ", vbYesNo, "الملف موجود مسبقا") = vbNo Then Exit Sub

		    ActiveSheet.Copy

		    ActiveWorkbook.SaveAs Filename:=MYPATH, FileFormat:=xlExcel12, CreateBackup:=False

		    Application.Windows(2).Activate

		    MsgBox ("تم إستبدال الملف ونقله إلى سطح المكتب ")

		    Windows(MyWok).Close

	   Application.DisplayAlerts = True

		    Exit Sub

	    End If

End Sub

[ابو تميم]

شكرا على الإفادة أساتذتنا الكرام وجزاكم الله خيرا

أنا نفذت الكود بهذه الطريقة قبل طرح السؤال ولكن النتيجة التي أريدها هي بقاء الاسم نفسه

وبعد استخدامي لهذا الكود توضح لي بأن الكود الأصلي في المشاركة 1 يعمل منه فقط الجزء الذي قمنا بحذفه وذلك لأن المطلوب من الكود هو نقل نسخة من الورقة الحالية إلى ملف جديد وتحفظ على سطح المكتب بنفس الاسم مع إغلاق الملف النسخة والإبقاء على الملف الاصلي مفتوح ومع عدم نقل الاكواد إلى الملف النسخة

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

لذك أنا قمت بالتعديل التالي حتى يقوم الكود بعمل المطلوب وذلك إذا تساوى اسم الملف مع اسم الورقة يتم نسخ المطلوب مع إضافة حرف إلى جانب الاسم الموجود بحيث يتغير اسم الملف الناتج ويتم الحفظ وفعلا نجحت الطريقة وأدت الغرض المطلوب

شكرا جزيلا لكم وجزاكم الله خيرا