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

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

الله يحفظك =IF(J15 < 0; "المبلغ ناقص"; "المبلغ كامل") اذا كان الرقم بالسالب تظهر كلمة المبلغ ناقص.xlsx

وعليكم السلام ورحمة الله وبركاته =IF(J15 < 0; "المبلغ ناقص"; "") اذا كان الرقم بالسالب تظهر كلمة المبلغ ناقص.xlsx

وعليكم السلام ورحمة الله وبركانه الملف ____أرقام الجلوس والمناداة - 2025 الرابع.xlsm

ممنون استاذ

ياأخي الفاضل @عمار العبيدي أفضل اجابة للأستاذ @Foksh وليست لي . رجاء إلغيها من عندي وسجلها للأستاذ @Foksh .

أستاذ @عمار العبيدي لي ملحوظة قد تفيدك مستقبلاً .عندما تصل لأفضل اجابة 1- لغلق الموضوع بأنه تم ليستفيد منه الجميع . 2- الكل بيسارع لمساعدتك، لتجاوبك . 3- وارضاء نفسي لمن ساعدك وحل لك طلبك .الضغط على (أفضل اجابة) على مشاركته .

كود برمجي لارسال رساله عبر الواتس اب من الاكسيل الحل المثالي لارسال اكبر عدد من الرسائل من الاكسيل للواتس اب الجديد الكود البرمجي كامل : Sub sendMessage() Dim contact As String Dim text As String num = Application.WorksheetFunction.CountA(Sheets("data").Range("a:a")) - 2 ActiveWorkbook.FollowHyperlink Address:="https://web.whatsapp.com/" Application.Wait (Now + TimeValue("00:00:07")) For I = 0 To num contact = Sheets("data").Range("c2").Offset(I, 0).Value text = Sheets("data").Range("g2").Offset(I, 0).Value Call SendKeys("^%{/}", True) Application.Wait (Now + TimeValue("00:00:05")) Call SendKeys(contact, True) Application.Wait (Now + TimeValue("00:00:05")) Call SendKeys("~", True) Application.Wait (Now + TimeValue("00:00:05")) Call SendKeys(text, True) Application.Wait (Now + TimeValue("00:00:01")) Call SendKeys("~", True) Application.Wait (Now + TimeValue("00:00:01")) Call SendKeys("^%{/}", True) Next I End Sub إرسال رسائل واتساب من إكسل: تُستخدم هذه العبارة بشكل عام للبحث عن طرق إرسال رسائل واتساب من خلال ملف إكسل. ربط إكسل بواتساب: تُشير هذه العبارة إلى البحث عن حلول لربط ملف إكسل بتطبيق واتساب لتمكين إرسال الرسائل تلقائيًا. ماكرو إكسل لإرسال رسائل واتساب: تُستخدم هذه العبارة للبحث عن أكواد ماكرو مخصصة لإكسل تسمح بإرسال رسائل واتساب. أدوات إرسال رسائل واتساب من إكسل: تُشير هذه العبارة إلى البحث عن برامج أو تطبيقات خارجية تعمل كوسيلة وسيطة لإرسال الرسائل من إكسل إلى واتساب. إرسال رسائل واتساب تلقائيًا من إكسل ربط إكسل بواتساب إرسال رسائل واتساب من إكسل . أتمتة واتساب باستخدام إكسل . VBA لربط إكسل بواتساب . ماكرو إكسل لواتساب . وهذا ملف اخر عدلة كما تريد اسهل طريقة ارسال وربط ملف الاكسيل بالواتس اب وارسال رسائل المدرسة او الشركة من الاكسيل للواتس اب.xlsm

مشاركتي الأخيرة في هذا الموضوع ملخص مقارنة لجميع المشاركات في ملف إكسل وصورة. الدالة المذكورة ومثيلاتها الثلاث صممت للأكسس مع تطابق تام مع دوال الإكسل بقدر الاستطاعة، وملف الإكسل ما هو إلا وسيلة للمقارنة فقط. موفقين جميعا، أنا لم أغادر أوفيسنا، ومتواجد في منتدى الإكسل لمن يريد متابعتي. CustomCeiling_01.xlsm

بسم الله الرحمن الرحيم برنامج ارسال الاف الرسائل بسهولة مطلقة علي الواتساب معتمد يصفة اساسية علي الVBA وترجمة الخطوات الروتينية لارسال رسالة واحدة علي الواتس اب وتنفيذها داخل حلقة تكرارية لارسال اي عدد ممكن بشرط الارقام تكون متسجلة علي سجل الهاتف الملف موجود للتحميل ولو اي حاجه وقفت قدامك وان شاء الله ده مش هيحصل فده فيديو شرح للبرنامج وبالمناسبة علشان مطولش علي حضرتكم علشان ليا سؤال عند خبراء المنتدي لو حد الموضوع هيفرق معاه وهيحتاج انه يجيب ارقام عليها واتساب او ينزل ارقام علي الاكسيل لسجل الهاتف الخاص بي ممكن يكتبلي في التعليقات والله العظيم هستغل البرنامج في الخير بس انت حلفت وانت حر بقي ربنا يستر علي الجميع ان شاء الله !! _____________________________________________ اتمني اكون قدمت قبل ما اطلب الخدمة انا في شغلي متبني جدا فكرة العمل الالي للكمبيوتر بتاعي وربنا بيوفقني وبعمل حاجات زمايلي في الادارات التانية مش بيصدقوا ان الكمبيوتر شغال لوحده وبينزل داتا او بيطبع ورق البيانات الي فيه مختلفة بس انا عايز انمي نفسي اوي في الحته دي كل اعتمتادي علي SENDKEYS مثلا او تحريك الماوس في ابعاد معينة والنقر وهكذا وباخد العمل الروتيني ده واحطه في بنية تكرارية من 1 ل 100 علي سبيل المثال وكل عده بيجلب بيانات معينة وينفذها اتمني حد يساعدني بمصدر ادرس منه لكي يكون الموضوع اكثر مهنيه مش مجرد اجتهادات مني بتنجح بامتياز الف حمد والف شكر ليك يارب بس عايز اكون اكثر اطلاع يارب يكون حد فهمني من اساتذتنا الكبار في المنتدي وبااااااااااارك الله فيكم whatsapp.xlsm

تفضل أخي @fuadco حسب مافهمت .ووافني بالرد . test4-1.rar

تعديل تم حل المشكلة الاولى وهي استدعاء الخلايا متبقى مشكلة التكرار استخدمت الكود المرفق ولكن فيه مشاكل ارجو المساعدة فى التصحيح او كتابة كود جديد Sub Task_MakeRecurring() Dim Freq As Long Dim FreqQty As Long Dim TotTime As Double Dim StartOnDt As Date, UntilDt As Date, StartDt As Date, EndDt As Date With Main 'If .Range("b5").Value = Empty Then 'MsgBox "Please make sure to enter a Task Name before saving" 'Exit Sub 'End If 'If .Range("b7").Value = Empty Or .Range("b8").Value = Empty Then ' MsgBox "Please make sure task has Start and End Dates to make them recurring" ' Exit Sub ' End If ' If .Range("B1").Value < 4 Then 'MsgBox "Please make sure to enter Recurring Frequency, Start On and Until Date fields to make this task Recurring" ' Exit Sub ' End If TotTime = .Range("g2").Value 'Total Time FreqQty = .Range("b14").Value 'Frequency Qty Freq = .Range("b13").Value 'Frequency StartOnDt = .Range("b15").Value 'Start On Date UntilDt = .Range("b16").Value 'Until Date StartDt = StartOnDt 'Set Initial Starting Date EndDt = StartDt + TotTime 'End Date is Start Date + Total Time Do While StartDt <= UntilDt 'Create Tasks Until Start Date is greater than Until Date .Range("b7").Value = StartDt 'Set Starting Date .Range("b8").Value = Int(EndDt) 'Set Ending Date (date as a whole number) Call Add_Data 'Save Task 'Update Start & End Dates for Next Task Select Case Freq Case Is = "Day(s)" StartDt = DateAdd("d", FreqQty, StartDt) Case Is = "Week(s)" StartDt = DateAdd("ww", FreqQty, StartDt) Case Is = "Months(s)" StartDt = DateAdd("m", FreqQty, StartDt) End Select EndDt = StartDt + TotTime 'Update End Date Loop End With Call Add_Data 'Update Task list End Sub Task Tracker test - Copy.xlsm

Sub TransferData2() Dim i As Long, Cnt As Long Dim ws As Worksheet, f As Worksheet, sWS As Worksheet Dim Sh As String, arr As Variant Dim tbl As ListObject, a As Range, lige As Range Dim j As String, newCode As String, b As String Set ws = ThisWorkbook.Sheets("تسجيل") Sh = ws.[G3].Value arr = Array(ws.[G4], ws.[G5], ws.[G6], ws.[G7]) For i = 0 To 3 If arr(i) = "" Then MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه" ws.Activate: arr(i).Select Exit Sub End If Next On Error Resume Next Set f = ThisWorkbook.Sheets(Sh) On Error GoTo 0 If f Is Nothing Then MsgBox "قائمة المخزون " & Sh & " غير موجودة", vbExclamation Exit Sub End If If MsgBox("هل ترغب في ترحيل بيانات التسجيل؟", vbYesNo + vbQuestion, "تأكيد الترحيل") = vbNo Then Exit Sub Set tbl = f.ListObjects(1) On Error Resume Next Set lige = tbl.ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeConstants).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) On Error GoTo 0 ' الكود الجديد If Not lige Is Nothing Then j = lige.Value '========= استبدل هدا '============== ' b = Left(j, Len(j) - Len(CStr(Val(j)))) ' Cnt = Val(Right(j, Len(j) - Len(b))) ' newCode = b & Cnt + 1 '====== بالكود التالي '========== Dim tmp As String, textPart As String For i = Len(j) To 1 Step -1 If IsNumeric(Mid(j, i, 1)) Then tmp = Mid(j, i, 1) & tmp Else textPart = Left(j, i) Exit For End If Next i If tmp <> "" Then Cnt = CLng(tmp) Else Cnt = 0 End If newCode = textPart & (Cnt + 1) Else newCode = ws.[G4].Value End If If Not lige Is Nothing Then Set a = lige.Offset(1, 0) Else Set a = tbl.ListColumns(2).DataBodyRange.Cells(1, 1) If a.Value <> "" Then Set a = tbl.ListColumns(2).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1) End If End If a.Value = newCode ' الكود a.Offset(0, 5).Value = 1 ' الكمية a.Offset(0, 2).Value = arr(1) ' الاسم a.Offset(0, 3).Value = arr(2) ' الوصف a.Offset(0, 7).Value = arr(3) ' الملاحظات a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ Set sWS = Sheets("المشتريات") Set tbl = sWS.ListObjects(1) On Error Resume Next Set lige = tbl.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) On Error GoTo 0 If Not lige Is Nothing Then Set a = lige.Offset(1, 0) Else Set a = tbl.ListColumns(3).DataBodyRange.Cells(1, 1) If a.Value <> "" Then Set a = tbl.ListColumns(3).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1) End If End If a.Cells(1, 1).Offset(0, -1).Value = Format(Date, "dd/mmmm") ' التاريخ a.Value = newCode ' الكود a.Offset(0, 5).Value = 1 ' الكمية a.Offset(0, 2).Value = arr(1) ' الاسم a.Offset(0, 3).Value = arr(2) ' الوصف a.Offset(0, 7).Value = arr(3) ' الملاحظات a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ End Sub مبيعات ومشتريات V3.xlsb

طريقة اخرى بدالة غير مباشرة Function GetHyperlinkAddress(rng As Range) As String On Error Resume Next GetHyperlinkAddress = rng.Hyperlinks(1).Address End Function ثم في العمود M نكتب =GetHyperlinkAddress(I2) لرابط اليوتيوب وفي العمود J نكتب لرابط الفيس =GetHyperlinkAddress(J2) الملف qrcode1.xlsb

المقصود عند دخول الورقة قائمة الاسماء قي العمود D كلما اضفت اسما او اكثر ولو كان مكررا تجده في القائمة في الخلية وهذا ما يقوم به الكود حاليا عند تغيير الاسم في الخلية I6 نجد مجموع الرواتب في M6 ومجموع السلف في M7 للموظف اذا كانت بياناتك بسيطة فمعادلان اما اذا كانت كبيرة فانصحك بالكود على كل حال اليك الحل عن طريق المعادلات ولك الخيار في استخدام ما يفيدك في عملك DC (1).xlsx

السلام عليكم حسب فهمي لطلبك Jجمع رواتب الموظف ووضعها في M6 وجمع سلفه ووضعها في M7 وذلك حسب الاسم في I6 ان كان كذلك جرب الملف القائمة في I6 يتم تحديثها عند الدخول الى الورقة لوحدها DC (1).xlsb

السلام عليكم اخى الفاضل الاسباب كثيرة منها ربما الإصدارين مثبتان بشكل صحيح وتوجد تعارضات بينهما ربما عدم وجود Microsoft Forms 2.0 Object Library ربما التحديثات التلقائية لأحد الإصدارين إلى تعطيل أو إفساد إعدادات الإصدار الآخر على كل حال ارفاق ملف يقفل باب ربما في انتظار ارفاق ملفك لاصدار 2016 وهو الموجود حاليا على جهازي لك كل الود والاحنرام

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim n As Range, f As String, count As Integer, i As Integer If Not Intersect(Target, Me.Range("A1:B2")) Is Nothing Then Dim WS As Worksheet: Set WS = Sheets("data") Dim xRow As Range: Set xRow = WS.Range("A1:J1") Dim tmp As Integer: tmp = xRow.Column xRow.ClearContents For Each n In Me.Range("A1:A2") If n.Value <> "" Then f = n.Value count = n.Offset(0, 1).Value For i = 1 To count If tmp > xRow.Columns.count + xRow.Column - 1 Then Exit Sub WS.Cells(xRow.Row, tmp).Value = f tmp = tmp + 1 Next i End If Next n End If End Sub test2.xlsb

السلام عليكم ورحمة الله وبركانه اظافة الى حل استاذنا احمد يوسف جزاه الله خيرا يمكن استخدام كود لاستدعاء اجور الطعام مع الاستحقاق مع اعتماد الخلايا الصفراء حال عدم وجود تاريخ معادلة بشروط1.xlsb

في العامود K لا يتعير شيء المعادلات تعمل في الصفحة الرئيسية و تنقل الى باقي البشيتات قيمتها فقط وذلك لتقليل حجم الملف من حيث عدد المعادلات فيه (اذ يمكن ان يتخيل الانسان 20 صفحة زيادة (حسب عدد العملاء) و في كل واحدة اكثر من 50 معادلة) فلماذا لا نجعل الاكسل يرتاح من حسابها

وازيدك من الشعر بيت .. العنوان غير مناسب 🙈