فاتورة بسريال متغير مع الحفط في فولدر الملف الاساسي برقم الفاتوره

[عادل حنفي]

السلام عليكم

الموضوع تم عمله سابقا

و لطلبه مرة اخري وصعوبة ايجاده

تم عمله بموضوع منفصل

لنتمكن من تطويره حسب ما يطلب

و لايجاده بسهوله

الملف يقوم بعمل الاتي

حفظ الفاتورة فقط برقمها في فولدر ملف الاكسل الاساسي

تغير سيريال الفاتوره

مسح الفاتوره الاساسية لتجهيزها لفاتورة جديدة

حفظ الملف الاساسي

تحياتي

Save invoice.rar

[ابو الآء]

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

استاذى الكبير عادل بارك الله فيك

عمل رائع كالعادة

[zine pef]

و عليكم السلام

ما شاء الله أخي على الملف الرائع

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

[عادل حنفي]

السلام عليكم

اخي abo_alaa

اخي zine pef

اشكركما لكلماتكما و مروركما

خالص تحياتي و تقديري

[احمد حمور-ابوعبدالله]

اخي عادل حنفي

بارك الله فيك وجزاك الله خيرا

[عادل حنفي]

السلام عليكم

اخي احمد حمور(ابوعبدالله)

اشكرك علي المرور و علي كلماتك الطيبة

تحياتي

[ahmady2340]

بسم الله الرحمن الرحيم

السلام عليكم

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

الرجاء شرح الكود ولو اريد عمل الكود على فاتورة من تصميمى

ثم لو اريد حفظ الفاتورة فى ملف خاص بالفاوتير كيف اكتب المسار فى الكود

ثم لو اريد عمل الطباعة ثم الحفظ

ارجو الافادة

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

[galo2020]

عمل جدا راااائع

يعطيك العااافيه

[عادل حنفي]

السلام عليكم

اخي galo2020

اشكرك علي كلماتك الطيبة

اخي ahmady2340

اولا اشكرك

و ثانيا الكود المستخدم هو

Sub save_file()

If Range("I6") = "" Then

'لتحديد اذاكان خلية رقم الفاتورة فرغ يتم اعطاء هذه الرسالة


MsgBox ("ادخل رقم الفاتوره")

Exit Sub

Else

Dim full_path As String

Dim aah As String

m = ActiveWorkbook.Name

'نعرف ان m هي اسم ملف الاكسل المفتوج

full_path = ThisWorkbook.Path & "\" & [i6].Value & ".xls"

'ماسبق يجعل الكلمة التي قبل ال = هي المكان الذي سيحفظ فيه الملف

aah = Dir$(full_path)

'يتم تعريف ال aah بانها كامل الاسم الذي سيحفظ به الملف

Workbooks.Add

'ادراج ملف اكسل جديد

N = ActiveWorkbook.Name

'نعرف ان N هي اسم ملف الاكسل النشط او اما تم ادراجه

    Windows(m).Activate

ActiveSheet.Range("B2:j44").Copy

'ننشط اسم الملف المفتوح و الذي عرفناه في البداية باسم m و ننسخ منه المدي المطلوب

Windows(N).Activate

ActiveSheet.Range("B2:j44").Select

ActiveSheet.Paste

'ننشط اسم الملف الجديد و الذي عرفناه باسم N و نحدد المدي المطلوب و نلصق به ما تم نسخه   

Columns("B:J").EntireColumn.AutoFit

Range("B2").Select

Application.CutCopyMode = False

Application.DisplayAlerts = False

If aah = [i6] & ".xls" Then

'اذا كان المكان الذي سيتم به حفظ الملف و الذي سيكون اسمه ما بالخلية i6 ,ونهايته .xls موجود به نفس الاسم 

MsgBox "الملف موجود بالفعل...."   

'تاتينا رساله بان الملف موجود بالفعل

ActiveWorkbook.Close

'نقفل الملف الجديد المفتوح

Application.DisplayAlerts = True

Exit Sub

Else

'اذا لم يكن اسم الملف موجود

ActiveWorkbook.SaveAs Filename:=full_path

'يتم حفظ الملف الجديد

Application.DisplayAlerts = True

ActiveWorkbook.Close

'اقفال الملف الجديد

Range("I6") = Range("I6") + 1

'في الملف الاخر محتوي الخلية i6  نزيده 1  

Range("c20:h41") = ""

Range("e10,e11,i10,g13,g15") = ""

Application.DisplayAlerts = False

ThisWorkbook.Save

Application.DisplayAlerts = True

End If

End If

End Sub

وان اردت تغيير مكان حفظ الملف سيكون التغيير في هذا السطر

full_path = ThisWorkbook.Path & "\" & [i6].Value & ".xls"

فمثلا لو اردت الحفظ في ال c في فولدر اسمه My work سيصبح هذا السطر كالتالي

full_path = "C:\My work\" & [i6].Value & ".xls"

اخي هذا شرح بسيط للكود و اي استفسار انا منتظر

تحياتي

[ahmady2340]

السلام عليكم

اخي galo2020

اشكرك علي كلماتك الطيبة

اخي ahmady2340

اولا اشكرك

و ثانيا الكود المستخدم هو

Sub save_file()

If Range("I6") = "" Then

'لتحديد اذاكان خلية رقم الفاتورة فرغ يتم اعطاء هذه الرسالة


MsgBox ("ادخل رقم الفاتوره")

Exit Sub

Else

Dim full_path As String

Dim aah As String

m = ActiveWorkbook.Name

'نعرف ان m هي اسم ملف الاكسل المفتوج

full_path = ThisWorkbook.Path & "\" & [i6].Value & ".xls"

'ماسبق يجعل الكلمة التي قبل ال = هي المكان الذي سيحفظ فيه الملف

aah = Dir$(full_path)

'يتم تعريف ال aah بانها كامل الاسم الذي سيحفظ به الملف

Workbooks.Add

'ادراج ملف اكسل جديد

N = ActiveWorkbook.Name

'نعرف ان N هي اسم ملف الاكسل النشط او اما تم ادراجه

    Windows(m).Activate

ActiveSheet.Range("B2:j44").Copy

'ننشط اسم الملف المفتوح و الذي عرفناه في البداية باسم m و ننسخ منه المدي المطلوب

Windows(N).Activate

ActiveSheet.Range("B2:j44").Select

ActiveSheet.Paste

'ننشط اسم الملف الجديد و الذي عرفناه باسم N و نحدد المدي المطلوب و نلصق به ما تم نسخه   

Columns("B:J").EntireColumn.AutoFit

Range("B2").Select

Application.CutCopyMode = False

Application.DisplayAlerts = False

If aah = [i6] & ".xls" Then

'اذا كان المكان الذي سيتم به حفظ الملف و الذي سيكون اسمه ما بالخلية i6 ,ونهايته .xls موجود به نفس الاسم 

MsgBox "الملف موجود بالفعل...."   

'تاتينا رساله بان الملف موجود بالفعل

ActiveWorkbook.Close

'نقفل الملف الجديد المفتوح

Application.DisplayAlerts = True

Exit Sub

Else

'اذا لم يكن اسم الملف موجود

ActiveWorkbook.SaveAs Filename:=full_path

'يتم حفظ الملف الجديد

Application.DisplayAlerts = True

ActiveWorkbook.Close

'اقفال الملف الجديد

Range("I6") = Range("I6") + 1

'في الملف الاخر محتوي الخلية i6  نزيده 1  

Range("c20:h41") = ""

Range("e10,e11,i10,g13,g15") = ""

Application.DisplayAlerts = False

ThisWorkbook.Save

Application.DisplayAlerts = True

End If

End If

End Sub

وان اردت تغيير مكان حفظ الملف سيكون التغيير في هذا السطر

full_path = ThisWorkbook.Path & "\" & [i6].Value & ".xls"

فمثلا لو اردت الحفظ في ال c في فولدر اسمه My work سيصبح هذا السطر كالتالي

full_path = "C:\My work\" & [i6].Value & ".xls"

اخي هذا شرح بسيط للكود و اي استفسار انا منتظر

تحياتي

[ahmady2340]

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

لو امكن لو اريد اضافة امر طباعة اولا ثم تنفيذ باقى الاكواد تباعا كما اوضحت انت من قبل ممكن الافادة

ثانيا الرجاء سرح هذا الجزء Range("c20:h41") = ""

Range("e10,e11,i10,g13,g15") = ""

Application.DisplayAlerts = False

ThisWorkbook.Save

Application.DisplayAlerts = True

[عادل حنفي]

السلام عليكم

اخي ahmady2340

Range("c20:h41") = ""

Range("e10,e11,i10,g13,g15") = ""

Application.DisplayAlerts = False

ThisWorkbook.Save

Application.DisplayAlerts = True

السطر الاول و الثاني لجعل لتفريغ محتويات المدي المحدد

السطر الرابع و هو امر حفظ الملف و تم وضعه بين السطر الثالث

و الذي يوقف اظهار رسالة هل تريد حفظ الملف ام لا

و السطر الاخير يفعلها مرة اخري بعد الحفظ

تم ارفاق ملف لطباعة الفاتورة التي تحفظها و لكن بشرط ان

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

جرب الملف و اخبرني النتيجة

تحياتي

Save invoice with print.rar

[ahmady2340]

شكرا جزيلا اخى الكريم اولا على اهتمامك وثانيا على كرمك وطيب معاملتك

شكرا وبارك الله فيك على هذة المعلومات التى افادتنى كثيرا

وجعل الله هذا العمل فى ميزان حسناتك

اخوك محمد احمدى

[احمد فضيله]

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

[عادل حنفي]

السلام عليكم

اخي ahmady2340

لا شكر علي واجب

اخي HaNcOcK

بارك الله فيك

خالص تحياتي و تقديري

[ابو الآء]

استاذى الحبيب

اسف على الاثقال عليك

ولكن عند نقل هذا الكود لمفى لم يعمل معى

بسبب عدم وجود خبره لدى فى الاكواد

هل تتكرم وتقوم بنقل هذا الكود الى ملفى

ام لا يمكن تنفيذه مع هذا الملف

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

واسف مره ثانية لاثقال عليك

المركز المالى للمدرسة للرفع.rar

[ياسر الحافظ]

الاستاذ عادل

تحية طيبة

الله يعطيك العافية للعمل وللتجاوب الرائع

وفقك الله

ياسر الحافظ

[عادل حنفي]

السلام عليكم

اخي abo_alaa

مرفق ملف ارجو تجربته و اخباري بالنتيجة

يتم حفظ الملف من خانة التاريخ فيتم حفظه برقم الشهر

اخي hyasser

بارك الله فيك و مشكور علي المرور

تحياتي

المركز المالى للمدرسة .rar

[ابو الآء]

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

استاذى الحبيب مهندس عادل

بارك لله فيك

واعانك على كثرة طلباتنا

الملف لم يعمل لدى اعطى خطاء واظهر محرر الفيجول بيسك

لا اعلم ما السبب

ـــــــــــــــــــــــــــــــ

Workbooks.Add

ActiveSheet.Name = o

Application.DisplayAlerts = False

Sheets("sheet2").Delete

Sheets("sheet3").Delete

Application.DisplayAlerts = True

n = ActiveWorkbook.Name

Ap

ــــــــــــــــــــــــ

الخطاء فى السطر باللون الاصفر

ارجوا منك اخبارى بالسبب

هل السبب عندى فى الجهاز

بارك الله فيك

[الشيباني1]

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

Save invoice.zip

[عادل حنفي]

السلام عليكم

اخي

لقد كانت فرصة لزيادة عدد الفواير الي يتم حفظها حيث كان في الملف السابق 26 فاتوره

اما الان فيصل الي 37830

كما تم تجهيز الكود لاظهار اي فاتورة تريد باستدعائها

كما تم التعديل في اشياء اخري لتسهيل العمل بالملف

اخي جرب الملف و اخبرني النتيجة

تحياتي

Invoice full pic.rar

[ياسر الحافظ]

الاخ / الاستاذ عادل :

جهود مشكورة وعمل رائع

وفقك الله

ياسر الحافظ

[عادل حنفي]

بارك الله فيك اخي ياسر

[saad abed]

اخى واستاذى عادل حنفى

اولا انت استاذ حتى ولو لم اشير الى ذلك

مجهود رائع وابداعات جباره

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

تحياتى

سعد عابد

[عادل حنفي]

بارك الله فيك اخي سعد بس الدعوات