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

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

أخي الكريم محمد الموافي جرب الكود التالي Sub TransferDataUsingFilterMethod() Dim WS As Worksheet, SH As Worksheet Dim LR As Long, LastRow As Long Dim X As Long, I As Long Set WS = Sheet1: Set SH = Sheet2 LR = WS.Cells(Rows.Count, 1).End(xlUp).Row LastRow = SH.Cells(Rows.Count, 1).End(xlUp).Row + 1 Application.ScreenUpdating = False With WS .AutoFilterMode = False .Range("A3:E3").AutoFilter Field:=5, Criteria1:="<" & 60 .Range("A4:E" & LR).SpecialCells(xlCellTypeVisible).Copy SH.Cells(LastRow, "A").PasteSpecial xlPasteValues .AutoFilterMode = False End With Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Done...", vbInformation, "YasserKhalil" End Sub وإليك الملف المرفق مع تعديل التنسيق قليلاً تقبل تحياتي Transfer Data Using Filter Method YasserKhalil.rar

تفضل هذه الطريقة لعلها تفي بالغرض سؤال أوفيسنا.rar

أخى الفاضل جرب المرفق test1.rar

يمكن ان يكون المطلوب مطلوب salim.rar

اخواني الكرام: عندما قمت بالاعداد لشرح موضوع Select Case توصلت الى عمل دالة جديدة تقوم باستخراج اسم المحافظة وتاريخ الميلاد والنوع من الرقم القومي المصري قد لا تكون هذه الدالة جديدة عليكم فقد قام عدد من الاساتذة واذكر منهم الاستاذ خبور بعمل دوال احترافية بهذا الخصوص ولكني احببت ان اضعها هنا للاستفادة منها الدالة تحوي على بارو مترين هما 1. A_Rng ويمثل خلية الرقم القومي 2. T ويمثل الخيار الخاص بالعنصر المراد استخراجه =============================== وهنا المتغير T ينقسم الى التالي اي عندما T = 1 يتم استخراج اسم المحافظة T = 2 يتم استخراج تاريخ الميلاد T = 3 يتم استخراج النوع سوء ذكر او انثى ==== ويصبح الشكل النهائي للدالة =A_ID(A_Rng;T) ارجو منكم التجربة وابداء الراي اليكم المرفق 2003 دالة معرفة.rar

جرب الكود بهذا الشكل (لم أختبر الكود) فقط قمت بإضافة نقطة قبل كلمة Cells للإشارة إلى ورقة العمل التي سيكون عليها الدور في الحلقة التكرارية دون تنشيط الورقة Sub DelAllData() Dim Ws As Worksheet Application.ScreenUpdating = False For Each Ws In ThisWorkbook.Worksheets With Ws .Range(.Cells(4, "A"), .Cells(Rows.Count, "J")).ClearContents End With Next Ws Sheets("Data").Activate Application.ScreenUpdating = True End Sub

أخي الكريم إليك الكود التالي عله يفي بالغرض Sub LoopMergedCells() Dim I As Long, lRow As Integer lRow = 1 For I = 7 To 236 Step 3 If I <> 7 And Right(I Mod 30, 1) = "7" Then I = I + 10 Cells(I, 1).Value = Cells(lRow, "M").Value lRow = lRow + 1 Next I End Sub وإليك ملف مرفق مطبق فيه الكود تقبل تحياتي Loop Through Merged Cells & Transfer Data From Unmerged Cells YasserKhalil.rar

ضع الكود التالى فى مديول جديد الكود لمسح النطاق من الخلية a4 الى آخر خلية فى العمود j فى كل الاوراق و أؤكد مرة أخرى لابد من تتطاق جميع الأورارق Option Explicit Sub delallData() Dim ws As Worksheet On Error Resume Next Application.ScreenUpdating = False For Each ws In ThisWorkbook.Worksheets With ws .Activate .Range(Cells(4, "A"), Cells(Rows.Count, "J")).ClearContents End With Next ws On Error GoTo 0 Sheets("data").Activate Application.ScreenUpdating = True End Sub تحياتى

السلام عليكم ورحمة الله وبركاته يأتيك باﻷخبار من لم تزود...عصر السرعة.

استاذ ياسر رائع جزاك الله كل خيراً

جرب المعادلة بهذا الشكل =IF(AND($E$1<>"",BL9<>"",BL9>$E$1),MOD(BL9-$E$1,1),0) ويرجى عند طرح موضوع أن يكون هناك مقدمة وشرح للمطلوب قبل إرفاق الملف ... لا ترفق الملف وفقط (دا حتى مفيش السلام عليكم) تقبل تحياتي

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

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

حضرتك هتكمل بكود الأستاذ سليم و لا الكود الأخير

بعد اذن اخي و صديقي ياسر هذا الحل تأمين salim.rar

عذرا نسيت انك مرقم التلاميذ فى كل الاوراق جرب ده عشان الترقيم Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Application.DisplayAlerts = False If Target.Column <> 3 Then Exit Sub Select Case Target.Value Case Is = 1 Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الاول").Range("B1000").End(xlUp).Offset(1, 0) Case Is = 2 Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الثانى").Range("B1000").End(xlUp).Offset(1, 0) Case Is = 3 Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الثالث").Range("B1000").End(xlUp).Offset(1, 0) Case Is = 4 Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الرابع").Range("B1000").End(xlUp).Offset(1, 0) Target.EntireRow.Copy Sheets("الصف الرابع").Range("A1000").End(xlUp).Offset(1, 0) Case Is = 5 Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الخامس").Range("B1000").End(xlUp).Offset(1, 0) End Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

مشكورين جدا اساتذتنا الكرام على مجهودكم الرائع وكرمكم الفائق تمت تجربة البرنامج على 64 وأصبح يعمل بصورة جيدة

المشكلة كلها ، ان مسميات الحقول عندك بالعربي ، فلما تكتبها في الكود ، فهي تقلب الكود!! اسمح لي افكك لك الكود ، حتى تستوعبه بطريقة افضل: شوف اكبر رقم "رقم الفاتورة مرحل" في الجدول "ترحيل فاتورة"' a = DMax("[رقم الفاتورة مرحل]", "ترحيل فاتورة") 'اذا a فاضية ، فبدلها الى صفر b= nz(a,0) 'اكتب هذه القيمة في الحقل "رقم الفاتورة مرحل" في النموذج Me.رقم_الفاتورة_مرحل =b+1 جعفر

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Application.DisplayAlerts = False If Target.Column <> 3 Then Exit Sub Select Case Target.Value Case Is = 1 Target.EntireRow.Copy Sheets("الصف الاول").Range("A1000").End(xlUp).Offset(1, 0) Case Is = 2 Target.EntireRow.Copy Sheets("الصف الثانى").Range("A1000").End(xlUp).Offset(1, 0) Case Is = 3 Target.EntireRow.Copy Sheets("الصف الثالث").Range("A1000").End(xlUp).Offset(1, 0) Case Is = 4 Target.EntireRow.Copy Sheets("الصف الرابع").Range("A1000").End(xlUp).Offset(1, 0) Case Is = 5 Target.EntireRow.Copy Sheets("الصف الخامس").Range("A1000").End(xlUp).Offset(1, 0) End Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub بعد اذن الاستاذ سليم هذه الاضافة أخى الكريم ضع الكود التالى فى حدث الورقة بمجرد ادخال رقم الصف فى العمود c يتم الترحيل مباشرة

أخي الحبيب المتميز رجب بوركت اينما كنت وفي كل وفت .. وجزيت خير الجزاء على كل ما قدمته من خدمة لإخوانك وأحبابك تقبل تحياتي

انت كنت في المسار الصحيح ، وببعض التغييرات ، تم اللازم بهذا الكود: Me.رقم_الفاتورة_مرحل = Nz(DMax("[رقم الفاتورة مرحل]", "ترحيل فاتورة"), 0) + 1 جعفر 253.الفانورة.accdb.zip

تحياتى لأستاذنا الفاضل بن عليه نعم كلامك صحيح 100 % جرب الملف ده لم أجربه بعد التعديل معنديش 64 64 توزيع الملاحظة.rar 64 توزيع الملاحظة.rar

بعد اذن استاذي الغالي/ رجب جاويش اضافة بسيطة للكود لجعله مرن اكثر بحث باول حرف من الاسم او البحث بالتاريخ فقط او الاسم فقط test1.rar

لغز برسم جميع الاصدقاء في المنتدى الرائع كيف يمكن الترقيم التلقائي مع وجود خلايا مدمجة فزورة.rar

أخى حمادة جرب المرفق ترحيل بيانات33.rar

هل تقصد هكذا حل الفزروة2.rar

أخى الصقر بالفعل فورم جميل ورائع تسلم ايديك أخى ياسر أنا فعلا أعتمدت فى الكود على ان الارقام غير مكررة جزاكم الله كل خير

تفضل أخى وعذرا للتأخير عليك ترحيل بيانات33.rar

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

أخي الكريم نايف الكود الذي قدمته يعتمد على اسم ورقة العمل وعنوان الخلية ثم يجلب الرقم .. الكود المقدم من قبل أخونا رجب يقوم بالبحث عن الرقم وجلب اسم ورقة العمل وعنوان الخلية ، وكذلك الفورم الرائع الذي قدمه أخونا حسام يقوم بنفس المهمة يعني تجيبها كدا شغالة وكدا شغالة .. تقبل تحياتي

رفع الله قدرك وبارك في علمك وجعل ذلك في ميزان حسناتك ...

اخى الحبيب والغالى ابوالبراء هذه نقطه فى بحر علمكم الفياض وما العبد الا قطره فى بحر علمكم اسعد الله صباحك بكل خير تقبل تحياتى ====================

أخي الكريم حامل المسك جرب الكود التالي ويمكن استبدال الحرف الموجود بأي حرف (بدلاً من حرف الفاء الموجود في الكود) Private Sub Worksheet_Change(ByVal Target As Range) If Target.Value = "ف" Then Application.EnableEvents = False With Target Target.Value = Time Target.NumberFormat = "hh:mm:ss" Columns(Target.Column).EntireColumn.AutoFit End With Application.EnableEvents = True End If End Sub تقبل تحياتي

أخي وحبيبي في الله حسام اسمح لي أن أصفق لك بحرارة (خصوصاً إن الجو برد والتصفيق في هذه الحالة سيشعرني بالدفء) صراحة والله عمل رائع وجميل والفورم مفيد جداً للبحث .. جزيت خيراً على هذه الهدية القيمة ولا حرمنا الله منك ولا من هداياك الثمينة (بالثاء وليس بالسين) الأخت الفاضلة ربا هل يمكن أن يتكرر الرقم في أكثر من ورقة عمل .. إذ أن الكود المقدم من أخونا رجب يعتمد على ايجاد أول قيمة للبحث فقط ، فهل هذا هو المطلوب ؟ الأخ الحبيب رجب جاويش كود رائع وجميل ولكن كما أسلفت يبحث عن أول قيمة فقط ..ماذا لو كان هناك أكثر من قيمة في أكثر من ورقة وربما كانت القيمة أكثر من مرة في الورقة الواحدة ؟؟ تقبلوا تحياتي

بعد اذن استاذى الفاضل / رجب جاويش والاستاذ الفاضل / ياسر خليل مرفق حل اخر باستخدام الاكواد بالفورم يتم كتابه الرقم المطلوب فى التكست بوكس باللون الابيض وشاهد النتائج فى اليست بوكس باللون الاصفر ولاظهار الفورم يتم الضغط على f6 سيظهر الفورم تقبلوا تحياتى ======================================== مثال.zip

حياك الله اخي الكريم ضع مربعي نص في النموذج وضع قيمة المعلمة بالطريقة التالية نفرض ان اسم الــنموذج form1 واسم حقل التاريخ الاول txtdate1 والتاريخ الثاني txtdate2 بدلا عن " ادخل قيمة معلمة" ضع السطر التالي في الإستعلام between forms!form1!txtdate1 and forms!form1!txtdate2 اذا لم تتضح الصورة ارفق مرفق للتطبيق بالتوفيق

تم حل المشكلة شكرا جزيلا جداااااااا سيدي ياسر خليل ابو البراء

إن شاء الله أستكمل غذاً العمل على الملف ..إلا إذا تدخل أحد الأخوة الكرام

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

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله أحياناً ما تحدث بعض المشاكل عند التعامل مع النوافذ الموجودة في محرر الأكواد .. كأن تختفي نافذة أو تتحرك نافذة من مكانها الذي تعودنا عليه ، وعند محاولة إرجاعها إلى مكانها لا نستطيع .. أنا مؤمن بمبدأ : بدلاً من تضييع الوقت في محاولة ترقيع الثوب المهلهل .. عليك بشراء ثوب جديد .. (وفر وقتك وفلوسك واحصل على نتيجة أفضل) أقصد من كلامي بدلاً من الخوض في تفاصيل معرفة حل المشكلة وقد يضيع الوقت في محاولة الحل وفي النهاية قد لا تصل لنتيجة مرضية أو يمكن أن تصل لنتيجة ويحدث خطأ في نقطة أخرى المهم موضوعنا عن كيفية إعادة ضبط إعدادات محرر الأكواد .. 1- اقفل برنامج الإكسيل (أو الأوفيس بشكل عام) 2- روح لقايمة Start في الويندوز ثم الأمر Run واكتب الأمر regedit للدخول إلى ريجستري الويندوز 3- روح لهذا المسار HKEY_CURRENT_USER\Software\Microsoft\VBA\6.0\Common\ بالنسبة للرقم 6 قد يكون مختلف حسب نسخة الويندو سواء كانت 32 بت ستجدها رقم 6.0 أما 64 بت فستجدها 7.1 أو 7.0 4- المهم ادخل على المجلد المسمى Common ، اعمل عليه كليك يمين ثم Delete (جمد قلبك ومتخافش .. لو حصل حاجة أنا مش مسئول) هتخرج لك رسالة تأكد الحذف .. انقر نعم يا بطل ومتخافش ..الويندوز هيسقط بس 5- افتح برنامج الإكسيل .. من لوحة المفاتيح اضغط Alt + F11 لتجد نسخة جديدة من محرر الأكواد (محرر الأكواد في ثوبه الجديد) كأنك لسه منصب أوفيس جديد ****************************** يمكنك إعادة ضبط الإعدادات التي تريدها .. الإعدادات التي أقوم بضبطها بشكل شخصي هي كالتالي : ** بعمل Maximize للنافذة اللي قدامي عشان تكون الصورة أوضح ** من Tools ثم Options أعلم علامة صح على الخيار Require Variable Declaration عشان أضيف السطر الخاص بإجبار المبرمج على الإعلان عن المتغيرات .. السطر دا بيكون شكله كالتالي Option Explicit ** من نفس النافذة أشيل علامة الصح من أول خيار Auto syntax Check عشان وأنا بكتب وغلطت متظهرش رسالة تنبيه بالخطأ ( واحد هيقولي طيب دي خاصية مفيدة .. ماشي كويس بس بتعطلني عن كتابة أسطر الكود ..يكفي أنني أرى السطر باللون الأحمر بعد الانتهاء منه .. هذا تنبيه كافي ) ** من نفس النافذة بدخل على التبويب المسمى Editor Format ثم أغير حجم الخط Size عشان أشوف أسطر الكود بشكل واضح ، ثم أوك في النهاية ** على يمين شريط الأدوات بعمل كليك يمين في مكان فارغ وبختار شريط Edit وبسحب الشريط وأضعه جنب شريط الأدوات القياسي (الموجود بالفعل) وفي نهاية المطاف .. أرجو أن يكون الموضوع (رغم بساطته) أن يكون مفيد لمن يريد التعامل مع محرر الأكواد) تقبلوا وافر تقديري وحبي واحترامي

جرب هذا الملف تاريخ تلقائي SALIM.rar

وبالنسبة للترحيل هل هو كما تريد ؟

السلام عليكم تم اجراء المطلوب بواسطة كود اخينا عبدالله باقشير نسأل الله ان يكون في ميزان حسناته Store Balance V3.2.rar

أخي الكريم مهند يرجى تغيير اسم الظهور للغة العربية إليك الملف التالي فيه حل بالكود بدلاً من التعامل مع المعادلات التي تثقل الملف في حالة التعامل مع كم هائل من البيانات أرجو أن يفي بالغرض Sub GetData() Dim Col As Long Dim Data As Variant Dim Dict As Object Dim N As Long Dim Rng As Range Dim Row As Long Dim Table As Variant Dim Wks As Worksheet Dim Addr As String Set Dict = CreateObject("Scripting.Dictionary") Dict.CompareMode = vbTextCompare ReDim Table(1 To 6, 1 To 1) For Each Wks In ThisWorkbook.Worksheets If Wks.Name <> "تصفية حسب الأشهر" Then Set Rng = Wks.Range("A1").CurrentRegion.Columns(2) Set Rng = Intersect(Rng, Rng.Offset(1, 0)).Resize(ColumnSize:=2) Col = Col + 1 Data = Rng.Value Addr = Rng.Address For N = 1 To UBound(Data) If Not Dict.Exists(Data(N, 1)) Then Row = Row + 1 Dict.Add Data(N, 1), Row ReDim Preserve Table(1 To 6, 1 To Row) Table(Col, Row) = Data(N, 2) Else Table(Col, Dict(Data(N, 1))) = Data(N, 2) End If Next N End If Next Wks Table = Application.Transpose(Table) With Worksheets("تصفية حسب الأشهر") .Range("B2").Resize(Dict.Count, 1).Value = Application.Transpose(Dict.Keys) .Range("C2").Resize(UBound(Table, 1), UBound(Table, 2)).Value = Table End With End Sub تقبل تحياتي Grab All Data From All Sheets YasserKhalil.rar

الله أكبر الله أكبر الله أكبر تجمع الأخوة الأحباء على قول لا إله إلا الله محمد رسول الله شرفت بمروركم جميعا أحبائى فى الله حبيبى الغالى / ياسر العربى حبيبى الغالى / محمد الخازمي حبيبى الغالى / عبد العزيز البسكرى حبيبى وأستاذى ومعلمى القدير / ياسر خليل تقبلوا جميعا تحياتى وتقديرى

المسألة في الدائرة الحمراء وهي المادة 3 ، تأكد انها دولة فيها الحروف التي في برنامجك ، العربية في حالتنا ، وعدم اختيار المربع في الرقم 4 : ثم تعيد تشغيل الكمبيوتر 🙂

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

بسم الله الرحمن الرحيم الأعضاء الأعزاء أسعد الله أوقاتكم بكل خير فيما يلي الدرس الرابع من دورة "إكسيل 2013 المستوى المتقدم" بعنوان: التصفية المتقدمة للبيانات الجزء الثاني الدرس الرابع- التصفية المتقدمة الجزء الثاني أتمنى لكم مشاهدة ممتعة ومفيدة يمكنكم تحميل ملفات التمارين الخاصة بهذه الدورة من خلال الرابط التالي: http://www.4shared.com/rar/QvwJQLddce/_-__.html لمتابعة الموضوع الرئيسي للدورة يمكنكم فتح الرابط التالي حيث جميع الدروس موجودة: دورة اكسيل 2013 المستوى المتقدم دمتم بخير أخوكم م/نضال الشامي Google+ كل الشكر والتحية للأخوة الذين شرفونا بالمرور والتعليق الايجابي

أخى الفاضل أ.ايهاب أولاً : الملف المرفق ليس له علاقة بالايجارات وانتهائها وخلافه فهو مجموعة موظفين ومكتوب به ارسال ايميل لبريد الموظف اذا انتهت الرخصة او الاقامة وغيرها ثانيا : هذه محاولة منى بناءا على الملف المرفق بارسال البريد تلقائي بمجرد فتح الملف للموظفين الذى انتهت بطاقاتهم او رخصهم وتستطيع انت التعديل به كما تريد بناءا على عملك .. استخدمت انا هنا بريد ال gmail لكل الناس سواء البريد الذي سترسل من خلاله الرسائل او الموظفين الذين سيستقبلون هذه الرسائل فبريد الموظف الاول على افتراض انه emp19811@gmail.com والثاني emp19812@gmail.com وهكذا وعلى افتراض ان البريد الذي سترسل من خلاله الرسائل هو Ibn_Egypt@gmail.com >> والباسورد الخاصة به هي A_123456789 يكون الكود بهذا الشكل Sub btnSendEmail() On Error GoTo 1 Dim Mail As New Message Dim ID, Licence As Boolean Dim Config As Configuration: Set Config = Mail.Configuration Dim LR As Long Dim i As Integer LR = Range("A" & Rows.Count).End(xlUp).Row For i = 2 To LR If Range("D" & i).Value < Date Or Range("C" & i).Value < Date Then If Range("E" & i).Value = "" Then Config(cdoSendUsingMethod) = cdoSendUsingPort Config(cdoSMTPServer) = "smtp.gmail.com" Config(cdoSMTPServerPort) = 25 Config(cdoSMTPAuthenticate) = cdoBasic Config(cdoSMTPUseSSL) = True Config(cdoSendUserName) = "Ibn_Egypt@gmail.com" Config(cdoSendPassword) = "A_123456789" Config.Fields.Update Mail.To = Range("A" & i).Value & "@gmail.com" Mail.from = Config(cdoSendUserName) ID = False If Range("C" & i).Value < Date Then ID = True Licence = False If Range("D" & i).Value < Date Then Licence = True If ID = True Then Mail.Subject = "انتهاء البطاقة" Mail.HTMLBody = "انتهاء البطاقة بتاريخ" & Format(Range("C" & i).Value, "yyyy/m/d") & "يرجي التواصل مع أقرب مكتب تجديد" End If If Licence = True Then Mail.Subject = "انتهاء الرخصة" Mail.HTMLBody = "انتهاء الرخصة بتاريخ" & Format(Range("D" & i).Value, "yyyy/m/d") & "يرجي التواصل مع أقرب مكتب تجديد" End If Mail.Send MsgBox "تم ارسال البريد بنجاح الى الموظف" & " " & Range("A", i).Value, vbOKOnly + vbInformation, "تم الارسال" Range("E" & i).Value = "تم التنبيه وارسال بريد" End If End If Next 1 End Sub في الكود السابق لابد ان تعدل البريد Ibn_Egypt@gmail.com... بالبريد الخاص بك وكذلك كلمة المرور اسفله الى كلمة المرور الصحيحة للبريد المكتوب كما انه يلزمك ايضا تفعيل هذه المكتبة من محرر الأكواد تختار Tools ثم References ,وتحدد علامة صح على المكتبة الموجودة بالصورة التى امامك ولكى تجعل الكود يعمل تلقائيا بمجرد فتح الملف .. يتم وضع هذا الامر في حدث فتح الملف Private Sub Workbook_Open() btnSendEmail End Sub مرفق ملف ومن اراد من الاخوة الأعضاء استخدامه يرجي التأكد من تغيير البريد في الكود وكذلك كلمة المرور وتفعيل المكتبة ... الكود مجرب ويعمل بنجاح والايميلات السابقة emp19811@gmail.com >>> emp19812@gmail.com حقيقية تحياتي email.rar