إنشاء ارتباط لفتح ملف موجود مسبقا وحفظة باسم جديد في نفس المسار

[ابو تميم]

عندما يتم الضغط في أحد المربعات الملونة يظهر لدينا رقم الصف الموجودة فيه البيانات المطلوبة للعمل

وهنا يصبح لدينا مسار صحيح هو

D:\PRO\data\[C3

وكما هو واضح قيمة الخلية [C3] تتغير بتغير موضع الضغط في المربعات الملونة

المطلوب :

عندما نضغط بالماوس ونحدد خلية معينة ويتكون لدينا مسار كما هو موضح أعلاه ويتم الضغط على زر إنشاء الملف يتم التالي:

أولا : يتم البحث في المسار المحدد \D:\PRO\data

فإذا كان الرقم موجود مسبقا يظهر لدينا رسالة مفادها أن هذا الملف موجود مسبقا هل تود استبداله ؟ Yes , No

فإذا تم الضغط على No يتم البقاء على هذه الصفحة دون إجراء أي أمر

أما إذا تم الضغط على Yes يتم نسخ الملف المرفق في مجلد data والمنسق مسبقا والذي اسمه Form ويتم نسخ قيمة الخلية [C3] من هذا الملف ولصقها في الخلية [C5] في الملف الثاني Form ويتم بعدها حفظ الملف مرة أخرى في نفس المجلد data ويكون اسمه هو نفس قيمة الخلية [C5] التي تم تحديدها ويكون امتدادها xlsm

PROG.rar

[ابو تميم]

up

[احمدزمان]

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

الموضوع محتاج مزيد من التوضيح

ماهو الملف المرفق

هل هو ملف4

او

الملف الذي تعمل عليه حاليا

[ابو تميم]

عذرا أخي أحمد

أي ملف 4 تقصد

المطلوب باختصار

أنا أقوم بالعمل على الملف الذي اسمه ( الرئيسي ) بشكل أساسي

وعندما أكون داخل هذا الملف ( الرئيسي ) يتم الضغط على أحد الخلايا الملونة بلون مختلف وخلال الضغط على هذه الخلايا إذا اختلف الصف يظهر لدينا في الخلية [c3] قيمة وهذه القيمة هي الرقم الموجود في العامود المسمى ( رقم ) وهو يمثل رقم الصف في الجدول

هنا وعند الضغط في خلية محددة يصبح لدينا مسار محدد كما هو موضح أعلى الجدول وهذا المسار ثابت ( D:\PRO\data) إضافة إلى قيمة الخلية C3 الموضحة سابقا وبالتالي يصبح لدينا المسار المطلوب هو المسار السابق نفسه بالإضافة إلى قيمة الخلية C3 ويصبح ( D:\PRO\data\[C3].xlsm ) طبعا يضاف الامتداد xlsm لأن المطلوب هو إنشاء ملف اكسل في المسار المحدد D:\PRO\data ويكون اسم هذا الملف هو قيمة الخلية C3 مضافا إليه الامتداد xlsm

وهنا ستسألني ما هو الملف الذي ترغب بإنشاؤه ويكون بهذا الاسم ؟؟؟

الجواب

الملف المراد إنشاؤه معد مسبقا داخل مجلد data واسمه Form.xlsm

وهنا وعند الضغط على الزر المقصود بالإنشاء للملف يتم وضع كود يعمل العمل التالي

أولا : يتم البحث في المسار المحدد أعلاه ( D:\PRO\data) عن الرقم أو القيمة الموجودة في الخلية C3 في الملف ( الرئيسي ) الموضحة سابقا وبالامتداد المطلوب فإذا كانت هذه القيمة موجودة وتم إنشاء ملف بهذا الاسم يظهر لدينا رسالة ( أن هذا الملف موجود مسبقا .. هل تريد استبداله ؟ ) وهنا يعطيني خيارين Yes , No فإذا ضغطنا على الخيار No يتم العودة إلى الملف ( الرئيسي ) بدون أي إجراء آخر

وإذا ضغطنا على Yes يتم البحث عن الملف Form.xlsm الموجود في مجلد data ويتم فتحه ويتم نسخ قيمة الخلية C3 من الملف ( الرئيسي ) ولصقها في الملف Form.xlsm في الخلية C5 الموجودة بلون أصفر في الملف Form وقيمتها هنا هي 4 وهذه القيمة مثال فقط

بعد ذلك وفي الملف Form يتم تسمية الورقة بقيمة الخلية C5 ويتم حفظ الملف باسم جديد وهذا الاسم هو قيمة الخلية C5 من الملف ( Form ) ويتم ربط قيمة الخلية C5 واسم الورقة واسم الملف الناتج النهائي باسم واحد بحيث إذا تغيرت قيمة الخلية C5 يتغير اسم الورقة ويتغير اسم الملف نفسه وطبعا هنا في الملف الجديد امتداده هو xlsm

بحيث يتم حفظ الملف الجديد والذي اسمه هو ( قيمة الخلية C5 ) وامتداده xlsm ... يتم حفظه في مجلد data بجانب الملف الذي اسمه Form.xlsm بحيث لا يتم تغيير اسم الملف Form ويتم الاحتفاظ بالاسم نفسه حتى يتم البحث عنه مرة أخرى عند الرغبة بإنشاء ملف جديد باسم جديد بحسب الرقم الجديد

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

وإن كان غير واضح أرجو التنبيه لذلك حتى أعود وأوضح ما هو غامض

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

[ابو تميم]

up

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

السلام عليكم

جرب الكود التالي:

Option Explicit

'//////////////////////////////////////////////////////

'  اسم الملف الناسخ

Const iNm As String = "Form.xlsm"

'//////////////////////////////////////////////////////


Sub kh_BookChange()

Dim Wo As Workbook

Dim sh As Worksheet

Dim iName As String, FilName As String

Dim nPath As String, oPath As String


Dim ch As String * 1

ch = Application.PathSeparator

'============================

On Error GoTo Err_kh_Files

'============================

Set sh = ThisWorkbook.ActiveSheet

FilName = CStr(Range("B3"))

iName = CStr(Range("C3")) & ".xlsm"

nPath = CStr(Range("A3")) & ch & FilName & ch & iName

'============================

'============================

    If Not Dir(nPath) = "" Then

        If MsgBox("أن هذا الملف موجود مسبقا هل تود استبداله ؟", vbYesNo, iName) = vbYes Then

            oPath = CStr(Range("A3")) & ch & FilName & ch & iNm

            If Not Dir(oPath) = "" Then

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

                kh_Application False

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

                Set Wo = Application.Workbooks.Open(oPath)

                With Wo

                    .Worksheets(1).Name = sh.Range("C3").Value

                    .Worksheets(1).Range("C5").Value = sh.Range("C3").Value

                    .SaveCopyAs nPath

                    .Close False

                    MsgBox "تم بحمد الله  "

                End With

            Else

                MsgBox "الملف : " & iNm & vbCr & "غير موجود"

            End If

        End If

    End If

'============================

'============================

Err_kh_Files:

kh_Application True

If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear

'============================

Set Wo = Nothing: Set sh = Nothing


End Sub


Sub kh_Application(mbol As Boolean)

With Application

    .DisplayAlerts = mbol

    .Calculation = IIf(mbol, -4105, -4135)

    .ScreenUpdating = mbol

    .EnableEvents = mbol

End With

End Sub

واشعرنا بالنتيجة

[ابو تميم]

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

جهودكم مشكورة بداية

تم تجربة الكود وهو يعمل في حال أن الملف موجود ونريد استبداله يتم استبداله بالملف الموجود مسبقا Form ويطبق المطلوب تماما ولكنه في حال أن الملف ليس موجودا أصلا فإنه لا يتغير شيء ولا يتم إنشاء ملف جديد

يعني إذا رغبنا بإنشاء ملف جديد ورقمه 3 مثلا وكان هذا الرقم غير موجود في المسار المحدد لا يتم إنشاء الملف ولكن إذا كان هذا الملف 3 مثلا موجود مسبقا يسألنا الملف موجود هل تريد استبداله .. وإذا ضغطنا نعم يتم استبدل الملف القديم بالملف الجديد مع أي تغييرات جديدة فيه

تم تعديل أكتوبر 16, 2012 بواسطه ابو تميم

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

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

جهودكم مشكورة بداية

تم تجربة الكود وهو يعمل في حال أن الملف موجود ونريد استبداله يتم استبداله بالملف الموجود مسبقا Form ويطبق المطلوب تماما ولكنه في حال أن الملف ليس موجودا أصلا فإنه لا يتغير شيء ولا يتم إنشاء ملف جديد

يعني إذا رغبنا بإنشاء ملف جديد ورقمه 3 مثلا وكان هذا الرقم غير موجود في المسار المحدد لا يتم إنشاء الملف ولكن إذا كان هذا الملف 3 مثلا موجود مسبقا يسألنا الملف موجود هل تريد استبداله .. وإذا ضغطنا نعم يتم استبدل الملف القديم بالملف الجديد مع أي تغييرات جديدة فيه

انا مشيت على الطلب

ولكن عملت حسابي لهذا السؤال

====================

مارايك لو الكود ياخذ امتداد الملف تلقائيا

من نوع الملف النشط

يعني الذي فيه زر انشاء ملف

مع ملاحظة :

اذا كنت تعمل على 2003

لازم يكون معاك نسخة من ملف Form بنفس الامتداد 2003

تفضل الكود:

Option Explicit

'//////////////////////////////////////////////////////

'  اسم الملف الناسخ

Const iNm As String = "Form"

'//////////////////////////////////////////////////////


Dim Wo              As Workbook

Dim iName           As String

Dim FilName         As String

Dim nPath           As String

Dim oPath           As String

Dim MyTyp           As String

'//////////////////////////////////////////////////////

'//////////////////////////////////////////////////////



Sub kh_BookChange()

'============================

Dim ch As String * 1

ch = Application.PathSeparator

'============================

On Error GoTo Err_kh_Files

'============================

With ThisWorkbook

    MyTyp = Mid$(.Name, InStrRev(.Name, "."))

End With

'============================

FilName = CStr(Range("B3"))

iName = CStr(Range("C3"))

oPath = CStr(Range("A3")) & ch & FilName & ch & iNm & MyTyp

'============================

If Dir(oPath) = "" Then

    MsgBox "الملف : " & iNm & vbCr & "غير موجود"

    Exit Sub

End If

'============================

nPath = CStr(Range("A3")) & ch & FilName & ch & iName & MyTyp

'============================

If Not Dir(nPath) = "" Then

    If MsgBox("أن هذا الملف موجود مسبقا هل تود استبداله ؟", vbYesNo, iName) = vbNo Then

        Exit Sub

    End If

Else

    If MsgBox("أن هذا الملف غير موجود مسبقا هل تود اضافته ؟", vbYesNo, iName) = vbNo Then

        Exit Sub

    End If

End If

'============================

kh_CopyBook

'============================

Err_kh_Files:

If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear

'============================

Set Wo = Nothing

End Sub


Sub kh_CopyBook()

On Error GoTo Err_kh_kh_CopyBook

kh_Application False

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

Set Wo = Workbooks.Open(oPath)

With Wo

    .Worksheets(1).Name = iName

    .Worksheets(1).Range("C5").Value = iName

    .SaveCopyAs nPath

    .Close False

End With

MsgBox ("تم بحمد الله حفظ الملف : " & vbCr & vbCr & oPath)

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

Err_kh_kh_CopyBook:

kh_Application True

End Sub


Sub kh_Application(mbol As Boolean)

With Application

    .DisplayAlerts = mbol

    .Calculation = IIf(mbol, -4105, -4135)

    .ScreenUpdating = mbol

    .EnableEvents = mbol

End With

End Sub

[ابو تميم]

سلمت يداك أستاذنا الكبير عبد الله باقشير

أنا طبقت الكود القديم قبل تحديثكم الأخير وعمل معي الكود بشكل ممتاز دون أخطاء ومن إعجابي وتقديري لجهودكم فرحت ودعوت لك دعاء من قلبي بأن يحفظك الله وأهلك وكل من تحب

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

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

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

سلمت يداك أستاذنا الكبير عبد الله باقشير

أنا طبقت الكود القديم قبل تحديثكم الأخير وعمل معي الكود بشكل ممتاز دون أخطاء ومن إعجابي وتقديري لجهودكم فرحت ودعوت لك دعاء من قلبي بأن يحفظك الله وأهلك وكل من تحب

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

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

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

----------------------------------

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

وهو نفس الكود في المشاركة 8

وعلشان تجرب الكود

مع اكسل 2003 -2007

PROG.rar