إنشاء مجلد على مسار محدد وحفظ ملف الاكسل عليه

[ابو تميم]

تحياتي لجميع المشرفين والعلماء والخبراء في هذا الصرح المتميز

المطلوب من هذا الملف هو عند الضغط على زر (حفظ الملف ) يتم تفحص المسارات

C:\data , D:\data , E:\data

وتفقد المجلد data بالأخص على المسارات المذكورة

فإذا لم تكن المجلدات ذات الاسم data موجودة على المسارات المحددة أو أحدها يتم إنشاؤه على المسار تلقائيا وحفظ ملف الاكسل عليها جميعا

ولكم جزيل الشكر والتقدير

إنشاء مجلد على مسار محدد وحفظ ملف الاكسل عليه.rar

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

اخي ابو تميم شاهد هذا الرابط

http://www.officena.net/ib/index.php?showtopic=36524&hl=&fromsearch=1

[ابو تميم]

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

وجدت طريقة أخرى على المنتدى على الرابط http://www.officena....=1

وقمت بتعديل الكود إلى التعديل التالي ليتناسب مع مطلبي ولا أعلم إن كان هذا الكود طويل أم لا ولكنه قام بالواجب وتم تنفيذ المطلوب بشكل ممتاز

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

Sub copy1()

Dim Extension$

Dim savePathName As String

Extension = ThisWorkbook.Name

savePathName = "c:\data\"

	On Error Resume Next

	Application.DisplayAlerts = False

	GetAttr (savePathName)

	Select Case Err.Number

	Case Is = 0

			Application.DisplayAlerts = False

			ThisWorkbook.SaveCopyAs savePathName & Extension

			Application.DisplayAlerts = True

	Case Else

			MkDir savePathName

			ThisWorkbook.SaveCopyAs savePathName & Extension

	End Select

	On Error GoTo 0


	Extension = ThisWorkbook.Name

savePathName = "d:\data\"

	  On Error Resume Next

	Application.DisplayAlerts = False

	GetAttr (savePathName)

	Select Case Err.Number

	Case Is = 0

			Application.DisplayAlerts = False

			ThisWorkbook.SaveCopyAs savePathName & Extension

			Application.DisplayAlerts = True

	Case Else

			MkDir savePathName

			ThisWorkbook.SaveCopyAs savePathName & Extension

	End Select

	On Error GoTo 0


End Sub

شكرا أخي ابو احمد على تعاونك

شكرا للجميع