ibn_egypt

اخى الفاضل هو حضرتك ليه تاعب نفسك وموزع البيانات بهذا الشكل العشوائي .. لن تخسر شيئا اذا تم وضع البيانات في جدول واحد بالعكس هتسهل على نفسك سواء الفلتر او وضع معادلات او حتى اكواد ... شاهد المرفق تحياتي فرز حسب شرط معين.rar

اخى الفاضل فيديو رائع، وأداة اكثر من رائعة ... جزاك الله كل خير تحياتي

اخى الفاضل تفضل الملف المرفق .. لربما به طلبك .. وعذرا للتأخير تحياتي ehab.rar

اخى الفاضل جرب اجعل معادلتك هكذا =Horof(ROUND(J9,0)) تحياتي

اخى الفاضل أولا هتفتح ملف اكسل جديد وتدخل على محرر الأكواد VBA بالضغط على ALT+F11 هتعمل موديول جديد وتلصق فيه الدالة بتاعتك "الكود السابق" ... ثانيا هتعمل حفظ باسم عادى جدا وقم بتسمية الملف باى اسم تريده ولكن يفضل باللغة الانجليزية .. اهم شئ انك تختار نوع الملف Excel Add-in xlam واحفظها في اى مكان على جهاز واقفل الملف ثالثا افتح ملف اكسل جديد او اى ملف اكسل لديك واختر ملف .. خيارات ... الوظائف الإضافية ... زر انتقال بالاسفل ... ثم اختر استعراض سيفتح اطار اختار الدالة التى قمت بحفظها على جهازك ثم موافق... الآن الدالة اصبحت مدمجة لاى ملف اكسل بجهازك اعتذر عن عدم التوضيح بالصور جرب ولو فيه شئ أخبرنا به تحياتي

اخى ايهاب مش مستوعب ايه نص الرسالة اللى انت عاوزها توصلك .. برجاء توضيح شكل المخرجات في حالة لو اقامه نص الرسالة عاوزها ".........................." في حالة سجل نص الرسالة يكون " .............................." في حالة محل نص الرسالة يكون "................................" تحياتي

اخى الفاضل أ.إيهاب اجعلها هكذا .. هتزبط معاك ان شاء الله Mail.BodyPart.Charset = "UTF-8" مرفق الملف للتوضيح تحياتي ehab.rar

اخى الفاضل أ.إيهاب تفضل هذا الكود الذي تريده مع مراعاة تغيير الايميل المكتوب بالكود الى الايميل الحقيقي لك وكتابة كلمة المرور الخاصة به .. والخلية A1 مكتوب بها البريد الذي تتم ارسال الرسائل اليه Sub btnSendEmail() On Error GoTo 1 Dim Mail As New Message Dim Config As Configuration: Set Config = Mail.Configuration Dim LR As Long Dim i As Integer Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("الايجارات") LR = Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False With ws For i = 4 To LR If Trim(.Cells(i, 4).Value) = "مطلوب" And .Cells(i, 8).Value = "" Then Config(cdoSendUsingMethod) = cdoSendUsingPort Config(cdoSMTPServer) = "smtp.mail.yahoo.com" Config(cdoSMTPServerPort) = 465 Config(cdoSMTPAuthenticate) = cdoBasic Config(cdoSMTPUseSSL) = True 'Change To Your Real yahoo Mail Config(cdoSendUserName) = "Ibn_Egypt@yahoo.com" 'Change To Your Real Password Config(cdoSendPassword) = "A_123456789" Config.Fields.Update Mail.To = .Range("A1").Value Mail.from = Config(cdoSendUserName) Mail.Subject = "اشعار" Mail.TextBody = "انتهاء" & " " & .Cells(i, 2).Value & " " & " للسيد " & .Cells(i, 1).Value & " " & "بتاريخ " & .Cells(i, 6).Value & " متبقي عليها " & .Cells(i, 7).Value Mail.Send MsgBox "تم ارسال البريد بنجاح" .Cells(i, 8).Value = "تم التنبيه وارسال البريد" End If Next End With Application.ScreenUpdating = True 1 End Sub مرفق الملف للتوضيح تحياتي ehab.rar

اخى الفاضل أ.ايهاب أولاً: ما نوع البريد الذي سيتم من خلاله ارسال الرسائل للناس .. Yahoo --Gmail ام غيرها لانك لو تريد الارسال من بريد من نوع اخر يتطلب لدينا معرفة SMTP Server وكذلك ال SMTP SERVER Port لهذا البريد ثانيا .. اين ايميلات الناس في الملف المرفق ثالثا ماهو شرط ارسال رسالة البريد ... برجاء قراءة المشاركات السابقة ومعرفة آلية عمل الارسال والإجابة على ما سبق تحياتي

اخوانى الأفاضل اهم شئ بالموضوع على الاطلاق هى تزبيط اعدادات البريد الذي تتم من خلاله ارسال الرسائل .. فنلاحظ بالكود الماضي هذه الأسطر وهى الخاصة بإعدادات بريد ال Gmail حيث أن البريد الذي تتم من خلاله ارسال الرسائل هو Ibn_Egypt@gmail.com 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 واذا كان البريد الذي تتم من خلاله ارسال الرسائل هو بريد ياهو على سبيل المثال والايميل الذي تتم من خلاله ارسال الرسائل Ibn_Egypt@yahoo.com لابد من تغيير الإعدادات السابقة بالإعدادات التالية Config(cdoSendUsingMethod) = cdoSendUsingPort Config(cdoSMTPServer) = "smtp.mail.yahoo.com" Config(cdoSMTPServerPort) = 465 Config(cdoSMTPAuthenticate) = cdoBasic Config(cdoSMTPUseSSL) = True Config(cdoSendUserName) = "Ibn_Egypt@yahoo.com" Config(cdoSendPassword) = "A_123456789" Config.Fields.Update اما بخصوص سؤال اخى الفاضل ابا الحسن ممكن تعدل سطر الكود وتجعله هكذا Mail.To = Range("A" & i).Value وبالخلايا اكتب البريد كامل وليكن aa@yahoo.com أو mm@gmail.com أو أى بريد اخر تريده .. الملف المرفق سيوضح لك الفكرة أخى ابو فارس حاول تعدل اللغة بالكلام المكتوب في الكود الذي تراه ... وكذلك لو بالملاحظات مكتوب تم التنبيه وارسال البريد لايتم الارسال .. تأكد ان الملاحظات فارغة وليس مكتوب بها اى شئ >>> وملاحظة أخيرة الياهو لا يدعم اللغة العربية قم بتحويل الرسائل المكتوبة باللغة العربية الى اللغة الانجليزية اذا كنت ستستخدم بريد الياهو تحياتي email.rar

اخى الفاضل طبعا ينفع تنسخ الكود وتلصقه بس تغير اسم الموديول اولا بدلا من FilterProduct سميه مثلا FilterProduct2 ثانيا مش مهم تغير ws,ws2 ... المهم تغير اسم الورقة يعني من Data الى Data2 او الورقة All تخليها بالاسم الجديد وليكن All2 وهكذا شاهد المرفق تحياتي بعد التعديل.rar

أخى الفاضل أ.ايهاب أولاً : الملف المرفق ليس له علاقة بالايجارات وانتهائها وخلافه فهو مجموعة موظفين ومكتوب به ارسال ايميل لبريد الموظف اذا انتهت الرخصة او الاقامة وغيرها ثانيا : هذه محاولة منى بناءا على الملف المرفق بارسال البريد تلقائي بمجرد فتح الملف للموظفين الذى انتهت بطاقاتهم او رخصهم وتستطيع انت التعديل به كما تريد بناءا على عملك .. استخدمت انا هنا بريد ال 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

اخى الفاضل وبعد إذن أستاذي القدير أ.ياسر، تفضل الملف المرفق به طلبك .. نصيحة أخ الأستاذ ياسر قام بشرح الكود جزاه الله كل خيرحاول فهمه لتقوم بالتعديل كما تريد في أى وقت تحياتي Transfer Rows.rar

أخى الفاضل وبعد إذن أستاذي القدير أ.ياسر .. اجعل الكود هكذا بزيادة جملة واحدة فقط Sub CopyRows() 'تعريف المتغيرات Dim LR As Long, I As Long, X As Long '[D]تحديد آخر صف به بيانات بالعمود LR = Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row 'متغير يحمل القيمة 5 كبداية للصفوف المراد نسخ الصفوف إليها ، أي أن الرقم 5 هو صف البداية للنتائج X = 5 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'مسح الصفوف في ورقة النتائج بداية من الصف الخامس إلى الصف الألف Sheets("Sheet2").Rows("5:1000").ClearContents 'وحتى آخر خلية بها بيانات لعمل شرط على قيمة الخلية[Sheet1]حلقة تكرارية بداية من الصف الرابع في ورقة العمل For I = 4 To LR 'إذا كانت قيمة الخلية في العمود الرابع تساوي واحد 'يقوم هذا السطر في حالة تحقق الشرط بنسخ الصف إلى ورقة النتائج في الصف الخامس كبداية 'بمقدار 1 استعداداً لنسخ صف جديد في حالة تحقق الشرط[X]ثم بعد عملية النسخ واللصق يتم زيادة المتغير If Cells(I, "D").Value = 1 OR Cells(I, "F").Value = 1 Then Rows(I).Copy Sheets("Sheet2").Range("A" & X): X = X + 1 'الانتقال لصف جديد لعمل اللازم Next I 'إلغاء خاصية النسخ واللصق Application.CutCopyMode = False 'تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub تحياتي

اخى الفاضل تفضل المرفق لربما به طلبك ... تحياتي TR.rar

اخى الفاضل ليس هكذا تورد الابل ... حضرتك لابد ان تشرح تفصيليا طلباتك، اشرح بالتفصيل الممل لاخوانك ما تريد واجعل طلبك واضحا وضوح الشمس في كبد النهار وبإذن الله ستجد من يلبي طلبك تحياتي

اخى الفاضل جرب الملف المرفق لربما به طلبك .. تحياتي بعد التعديل.rar

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

أخى الفاضل جرب الملف المرفق لربما به طلبك تحياتي FrameScrollBars.rar

اخى الفاضل بعد إذن استاذي القدير أ.عبدالله باقشير .. اجعل الكود هكذا Private Sub UserForm_Activate() Dim Sh As Object Dim LastCol, i As Integer Set Sh = ThisWorkbook.Sheets(1) LastCol = Cells(2, Sh.Columns.Count).End(xlToLeft).Column MyTop = 10 For i = 1 To LastCol Set txt = Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i) With txt .Text = Cells(2, i) .SpecialEffect = fmSpecialEffectSunken .TextAlign = fmTextAlignCenter .Top = MyTop .Left = 20 .Height = 24 .Width = 114 .BackColor = &HFFFFFF End With MyTop = MyTop + 30 Next If MyTop + 30 < Me.Height Then Me.ScrollBars = fmScrollBarsNone Me.Frame1.KeepScrollBarsVisible = fmScrollBarsNone Else Me.ScrollBars = fmScrollBarsVertical Me.Frame1.KeepScrollBarsVisible = fmScrollBarsVertical Me.Frame1.ScrollHeight = MyTop End If End Sub تحياتى

اخى الفاضل حاضر .. تفضل المرفق لعله طلبك باذن الله تحياتي ترحيل .rar

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

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

اخى الفاضل أ.مختار جزاك الله كل خير أخي الكريم وجعل عملك في ميزان حسناتك ... فكرة جميلة ورائعة تسلم ايدك ورحم الله والدك ووالدي وجميع موتانا وموتي المسلمين .. وبارك الله لك في أبنائك وجعلهم قرة عين لك ولكن ايه رايك نضيف اضافة بسيطة على الكود بحيث نجعل انه ليس من الضرورى الحفظ في ال D بل يتم الحفظ في نفس مسار ملف الاكسل كما يتم حفظ الصورة بالتاريخ والوقت الذي التقطت فيه حتى لا يتم استبدال الصورة الجديدة بالصورة الموجودة سابقا هذا الكود بعد الاضافة البسيطة Sub make_jpeg() Dim i As Integer Dim intCount As Integer Dim objPic As Shape Dim objChart As Chart Dim savedate savedate = Date Dim savetime savetime = Time Dim formattime As String formattime = Format(savetime, "hh.mm.ss") Dim formatdate As String formatdate = Format(savedate, "DD-MM-YYYY") 'نسخ المدى كصوره Call Sheet1.Range("A1:f13").CopyPicture(xlScreen, xlPicture) 'مسح أى أشكال من شيت 2 intCount = Sheet2.Shapes.Count For i = 1 To intCount Sheet2.Shapes.Item(1).Delete Next i 'عمل جدول فى شيت 2 Sheet2.Shapes.AddChart 'تنشيط شيت 2 Sheet2.Activate 'تحديد الجدول الذى يوجد فى شيت 2 Sheet2.Shapes.Item(1).Select Set objChart = ActiveChart 'لصق المدى اللى نسخناه فى هذا الجدول Sheet2.Shapes.Item(1).Width = Range("A1:f13").Width Sheet2.Shapes.Item(1).Height = Range("A1:f13").Height objChart.Paste 'حفظ الجدول كصورة فى المسار التالى objChart.Export Filename:=ThisWorkbook.Path & "\" & "Mokhtar" & formatdate & " " & formattime & ".jpg" End Sub ومرفق الملف للتوضيح تحياتي range 2 jpeg.rar

اخى الفاضل جرب الملف المرفق، تم التعديل بناءا على طلبك تحياتي Transfer-Products.rar