حفظ ملف بأسم خلية متغيرة داخل الملف

[oyousef]

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

تحية طيبة لاساتذة المنتدى اللذين دائما احظى بمساعدتهم واتعلم منهم الكثير

وبعد

اود المساعده فى الاتى

اريد كود ينشئ نسخة من sheet 4 بالملف المرفق وتكون النسخة تحوى القيم والتنسيقات فقط ثم وضعها فى ملف اكسيل جديد وتحفظ على drive C بالاسم الموجود داخل الخليتان c4,d4 الموجدتان داخل sheet4 علما بان محتوى الخليتان المذكورتان متغير

مع خالص شكرى وامتنانى لكم وجزاكم الله كل الخير عن مساعدتكم لنا دوما :fff:

Return.rar

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

FileFormat:=xlNormal

اخي الفاضل

جرب المرفق

سيتم حفظ نسخة طبق الاصل للشيت بما يحتويه sheet 4

Sub Abu_Ahmed()

On Error GoTo 10

	Sheets("Sheet4").Select

x = Range("C3").Value & " " & Range("D3").Value

	Sheets("Sheet4").Copy

	ChDir "C:\"

	ActiveWorkbook.SaveAs Filename:="C:\" & x & ".xls", FileFormat:=xlNormal, _

		Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _

		CreateBackup:=False

	ActiveWindow.Close

	Range("H2").Select

10 End Sub

Return.rar

[oyousef]

الاخ الفاضل الاستاذ ابو احمد

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

حيث يتم عمل نسخه من الملف ولكن لا يتم حفظها أو تغيير اسمها فتظل النسخة بأسم

Book1

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

اسف اخي الفاضل (الميكرو تم تسجيله على اكسل 2007) والنتيجة انه لم يعمل على 2003

تم استبدال الملف وتعديل الكود

جرب ان شاء الله سيعمل الان باذن الله

[الـعيدروس]

السلام عليكم

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

كود جميل

وربما هكذا

Sub copy_sh()

Dim F_FOL As String

  Application.ScreenUpdating = False

  F_FOL = "C:\"

  FName = Sheets("Sheet4").Range("c3").Text & " " & Sheets("Sheet4").Range("d3").Text

  With ActiveWorkbook

    Sheets("sheet4").Copy

    ActiveWorkbook.SaveCopyAs Filename:=F_FOL & FName & ".xls"

    ActiveWorkbook.Close False

    .Activate

  End With

  Application.ScreenUpdating = True

End Sub

[oyousef]

الاخ الفاضل ابو احمد

اين هو الكود الجديد الملف مازال يحوى الكود القديم

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

اخي يوسف

هل جربي الملف (انا قمت باعادة رفعه)

[oyousef]

اخي يوسف هل جربي الملف (انا قمت باعادة رفعه)

الاخ الفاضل ابو احمد

لك منى كل الشكر وكل الاسف لانى ارهقتك ولكن

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

جزاك الله كل خير على مجهوداتك

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

نعم اخي يوسف لم يتم تغيير جوهري في الكود

تم تغيير هذه الجزئية فقط

FileFormat:=xlNormal

وانا جربت الكود والكود يعمل عندي (ارجو ممن جرب ان يعلمنا بالنتيجة)

والله اعلم

[oyousef]

نعم اخي يوسف لم يتم تغيير جوهري في الكود

تم تغيير هذه الجزئية فقط

FileFormat:=xlNormal

وانا جربت الكود والكود يعمل عندي (ارجو ممن جرب ان يعلمنا بالنتيجة) والله اعلم

Sub acopyof()

'

    Dim FName		   As String

    Dim FPath		   As String


'Daily Movement file saving Path

    FPath = "C:\fr\supdata\FPDM"

    Sheets("sheet4").Select

    ActiveSheet.Copy

    Range("d3").Select


    Selection.Copy

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

	    :=False, Transpose:=False

    Application.CutCopyMode = False


    FName = Sheets("sheet4").Range("c3").Text & " " & Sheets("sheet4").Range("d3").Text


    ActiveWorkbook.SaveAs Filename:="C:\supData\Fr\" & FName


    Range("A4:f73").Select

    Selection.Copy

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

	    :=False, Transpose:=False

    Range("A1").Select

    Application.CutCopyMode = False

    ActiveSheet.Unprotect

    ActiveSheet.Shapes("Button 1").Select

    ActiveSheet.Shapes.Range(Array("Button 1", "Button 2")).Select

    Selection.Delete

    End Sub

الاخ الفاضل ابو أحمد

لك منى كل شكر فالطالما كنت عونا لى

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

حاولت اجرب الكود مرارا وتكرارا وجربت ان اغير فيه ولكن لم ينجح

فحاولت ان اصنع كود اخر ليتلائم مع متطلباتى كلها واظن انى افلحت هذه المره

وهذا هو الكود

واتمنى ان لا اكون اثقلت عليك

ولك منى كل الشكر

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

الحمدلله

المهم انك توصلت الى ما تريد

[ريان أحمد]

السلام عليكم الكود يعمل بشكل جيد في نسخة 2003 وهو كود رائع لك مني جزيل الشكر أستاذي القدير