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

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

وعليكم السلام استخدم الدالة RANK أخي الكريم: =RANK(B6;$B$6:$B$28;1) المصنف1.xlsb

1000 مبروك

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

وعليكم السلام ورحمة الله وبركاته 🙂 وهنا أيضا :

شاهد هذا الموضوع

السلام عليكم و رحمة الله الف مبروك يا كبير ..... نهنئ انفسنا قبل تهنئتك

السلام عليكم ورحمة الله تعالى وبركاته تهانينا الحارة للأستاذ الكريم حسونة مباركة هذه الترقية ، التي هي تشريف وتكليف ، راجياً أن تكون أعباء هذه المهمة خفيفة عليكم أخي الكريم مع خالص أمنياتي.. 🎉🎉 Congratulations 🎉🎉

السلام عليكم ورحمة الله وبركاته أزكى وأرقى الأماني الطيبة أزفها لأخي الحبيب حسونة على هذه الترقية💥💥💥 راجياً من الله تعالى أن يجعلنا وإياكم في خدمة العلم النافع ، وأن يجعله بميزان حسناتنا جميعاً. أخي حسونة @hassona229 مباركة عليكم هذه الترقية.💯 والسلام عليكم.🌼🌺

ذكرني هذا الموضوع بمنشور قديم تم استخدام نفس التقنية فيه 😊👌🏻 .. أعيد تذكيركم به .. مع إسبال الشكر الجزيل للأساتذة الأعزاء المهندسين قاسم وخالد .. نفعنا الله بهما .. وأمد في أعمارهما 🙂🌹

الف مبروك و مرحبا بك أخي حسونة 💐

عرفانا للجميل، وردا لبعض ما استفدته من هذا المنتدى المبارك، أقدم لإخواني (ماكرو تشكيل آلي) أستفيد منه كثيرا في مجال التشكيل، وهو عبارة عن ماكرو يقوم بالتالي: 1- ينسخ الكلمة أو الكلمتين، أو أكثر حسب تحديد الباحث، ثم يبحث بها في ملف آخر مشكول. 2- إذا وجد النص الذي يبحث عنه، فإنه ينسخه ويرجع إلى الملف غير المشكول، ليقوم باستبدال كل الكلمات غير المشكولة، فيضع مكانها المشكولة. 3- إذا لم يجد ما يبحث عنه، رجع إلى الملف ونسخ النص التالي ليبحث عنه، وهكذا. 4- يقوم بتلوين الكلمات المشكولة باللون الأحمر. 5- وفي نهاية العمليات يحفظ الملف بشكل آلي. 6- والمطلوب: أن تفتح ملف آخر مشكول ليبحث فيه الماكرو، فمثلا إذا كنت تشكل كتابا في الفقه فعليك أن تفتح ملفا آخر لكتاب فقه مشكول لينقل منه. 7- يجب أن تسمي الملف الذي تنقل منه التشكيل برمز معين، وليكن مثلا (----). 8- عند تشغيل الماكرو تخرج رسالة بعدد الكلمات المطلوب تشكيلها + 1 ، يعني لو أردت تشكيل كلمتين، فاكتب (3)، وإذا أردت تشكيل (4) اكتب (5)، وهكذا 9- والرسالة الثانية عدد مرات التكرار، يعني تكرر الأمر 100 مرة، أو 200، أو 1000، وهكذا. 10- والرسالة الثالثة فيها تحديد المدة، فيمكن أن تحدد المدة بالدقيقة، فلو كتبت (1) فهذا يعني أن الماكرو يعمل لدقيقة ثم يقف، ولو كتبت (2) فسيقف بعد دقيقتين، وهكذا. وهذا هو الماكرو لمن أراد: Sub تشكيلآلي() ' ' تشكيلآلي Macro 'ماكرو يشكل كلمات ملف من ملف آخر مشكول، بشرط فتح الملفين في آن واحد، وعند تشغيل الماكرو تختار عدد الكلمات المراد تشكيلها، كما تختار عدد مرات تكرار ذلك في الملف 'تمت إضافة تحديد الوقت في هذا الماكرو، فإذا كتبت (1) في مربع الوقت فهذا يعني دقيقةواحدة، وإذا كتبت(2)فهذايعني دقيقتين، وهكذا Dim X, a, b, c, y As Integer Dim t As Date t = Now Dim startTime As Date startTime = Now Do k = (InputBox("اكتب عدد الكلمات + 1")) X = (InputBox("اكتب عدد مرات التنفيذ")) y = (InputBox("حدد مدة تشغيل الماكرو بالدقيقة")) For i = 1 To X Selection.MoveRight unit:=wdWord, count:=1, Extend:=wdExtend If DateDiff("n", startTime, Now, endTime) = y Then ' s =عدد الثواني ' n =الدقائق ' h =ساعة MsgBox "تم تشكيل الكلمات وتلوينها باللون الأحمر" & Format(Now - t, " والوقت المستغرق = h:n:s ") Exit Do Exit Sub ActiveDocument.Save End If If (Len(Selection.Text) - 2 > 0) Then If Selection.Find.Found = False Then Windows(2).Activate Selection.MoveRight unit:=wdCharacter, count:=1 End If Selection.MoveLeft unit:=wdCharacter, count:=1 Selection.MoveLeft unit:=wdWord, count:=1 Selection.MoveLeft unit:=wdCharacter, count:=1 Selection.MoveRight unit:=wdWord, count:=k, Extend:=wdExtend a = Selection.Text Windows(1).Activate Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = a .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute If Selection.Find.Found = False Then Windows(2).Activate Selection.MoveRight unit:=wdCharacter, count:=1 Else b = Selection.Text Windows(2).Activate Selection.MoveRight unit:=wdCharacter, count:=1 Selection.Find.ClearFormatting Selection.Find.Replacement.Font.Color = wdColorRed With Selection.Find .Text = a .Replacement.Text = b .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = True .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute replace:=wdReplaceAll Selection.MoveRight unit:=wdWord, count:=1 End If End If Next i Beep MsgBox "تم تشكيل الكلمات وتلوينها باللون الأحمر" & Format(Now - t, " والوقت المستغرق = h:n:s ") Exit Do Exit Sub Loop ActiveDocument.Save End Sub

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته هذه فكرة للمتخصصين في إكسيل أحب أن أفتح النقاش فيها ودعة للمتختصين لتعديلها تجربة.xls

السلام عليكم و رحمة الله اجعل المعادلة هكذا : =IF(ISERROR(INDEX(datoza;MATCH(B7;INDIRECT($L$5);0);15));"";INDEX(datoza;MATCH(B7;INDIRECT($L$5);0);15))

طيب انت لي ماترفق مثال عشان تسهل عليك وعلينا ؟ كنت من الصبح بتلاقي الحل !!

تفضل اخي اليك طلبك Sub ChangeColor2() 'البحث في عمود("E") Application.ScreenUpdating = False Dim Rng As Range Dim MH As String Dim MH2 As String Dim x As Long Dim m As Long Dim y As Long Dim xFNum As Integer Dim xArrFnd As Variant Dim xStr As String MH = Range("F2").Value If Len(MH) < 1 Then Exit Sub xArrFnd = Split(MH, ",") Range("E1:E100000").Select For Each Rng In Selection With Rng For xFNum = 0 To UBound(xArrFnd) xStr = xArrFnd(xFNum) y = Len(xStr) m = UBound(Split(Rng.Value, xStr)) If m > 0 Then MH2 = "" For x = 0 To m - 1 MH2 = MH2 & Split(Rng.Value, xStr)(x) .Characters(Start:=Len(MH2) + 1, Length:=y).Font.ColorIndex = 3 MH2 = MH2 & xStr Next End If Next xFNum End With Next Rng Range("F2").Select Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''' 'البحث في عمود a,b Sub ChangeColor() Set MR = Range("A1:B10000") For Each cell In MR If cell.Value = Range("F2") Then cell.Interior.ColorIndex = 6 End If Next End Sub MH.xlsm

جهازك يرسل وما يستقبل ، يا أخي تفاعل مع من يقدم لك حلول لمشكلتك. للحل ثلاث معالجات (تاريخ ورقم ونص) حسب نوع حقل الساعات. الآن فقط فهمنا أن نوع الحقل عندك نص ، وأكيدا هذا خطأ في التصميم ومع ذلك حله سهل جدا. وأنا عندي الحل بعد معرفة النوع ولكن لن أواصل معك ، البركة في الباقي. ارفق مثالا وخذ الحل من الشباب بشكل صاروخي. موفق.

وعليكم السلام بالنسيبة للحالة الاولى ضع الكود التالي في مصدر بيانات الكمية المخزنية بالمناسبة ..لايحبذ استخدام اللغة العربية حتى لا تحصل لخبطة في الاكواد جرب النتيجة ..والله كريم على النقطة الثانية =IIf(IsNull([اسم الصنف]);"";DLookUp("[الموجود في المخزن]";"الموجود في المخزن";"[المعرف] = " & [اسم الصنف].[Column](0)))

بارك الله فيكم اساتذتنا الكرام هذا ماكنت ابحث عنه

طيب ادخل الرقم السري .... وجرب ... Book Info.accdb

أخي الكريم ..عدل المعادلة كما يلي: =RANK(B6;$B$6:$B$28;0) المصنف1 (1).xlsb

انت طلبت من شخص معين الرد عليك اجعل الموضوع عام وفي المنتدى خبراء كثر والاستاذ جعفر عمله طيب وسيرد عليك ان شاء الله قد يفيدك هذا المثال المرفق https://wayprograms.blogspot.com/2022/06/qr-code-in-access.html بالتوفيق

هذا سؤال آخر ليس له علاقة بطلبك الأول أخي وغير واضح!!!!

1- البحث عن طريق ادخال قيمة البحث في خلية معينة. 2- عند العثور على القيمة يذهب المؤشر الى الخليه التي فيها القيمة وتلوينها باللون الاصفر أخي قد تمت الاجابة بناءا على طلبك هذا !!!!! أما بالنسبة للمتسلسلة قد تم تجربتها هي كذلك . يتم تلوين محتوى الخلية بالكامل ربما أخي تقصد تلوين أرقام معينة داخل الخلية لأنك واضع المتسلسل (257500- 262449) في خانة واحدة...؟؟؟؟؟

بالتوفيق إن شاء الله.

وعليكم السلام ورحمة الله وبركاته إن كنت تريد إجمالي الغياب يرجى وضع المعادلة التالية في الخلية Y7 =SUM(COUNTIFS(C7:X7;"غ");COUNTIFS(C7:X7;"م");COUNTIFS(C7:X7;"ب")) وفي الخلية Z7 =COUNTIFS(C7:X7;"م") ثم اسحب نزولاً ..بالتوفيق إن شاء الله تعالى .والسلام عليكم

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

وعليكم السلام ورحمه الله وبركاته بارك الله فيك اخى AbuuAhmed بارك الله فيك اخى ابويوسف محمد حسن المحمد بارك الله فيك اخى المشرفي بارك الله فيك اخى ابراهيم الحداد بارك الله فيكم اخوانى واساتذتى جميعا واسأل الله تعالى أن يجعلنا جميعا في خدمة العلم النافع ، وأن يجعله بميزان حسناتنا جميعاً يوم القيامة آمين يارب العالمين

السلام عليكم ..أخي الكريم إن أصبت فبها ونعمت وإن أخطأت فالرجاء - من السادة الزملاء - المشاركة بعلمكم الزاخر... 1399540541_QrcodeWaleed.xlsb

هههههه اذا انت من المبتدئين احنا اين نكون بل انت استاذ ومعلم قدير وافكارك متميزه If ctl.Tag = "*" Then هذه الطريقة سبق ان استخدمتها في بعض البرامج ولكن تراجعت عنها بعد صعوبات من قبل المستفيدين من البرنامج عند محاولة بعضهم تطوير البرنامج وافضل استخدم قيمة او اسم العنصر

السلام عليكم ..أخي الكريم هذه محاولة أرجو أن تكون مفيدة test.xlsm

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

نعم تماما كما ذكرت مهندسنا العزيز .. وأضيف أني أرى من الأسهل استخدام خاصية الـ Tag بوضع علامة معينة عليه للعناصر المراد التحكم بها ( وذلك للخروج من متاهات أسماء العناصر وأنواعها ) 😅 نضع العلامة أو الرمز هنا : ثم نستخدمها في الكود هكذا : For Each ctl In Me.Controls If ctl.Tag = "*" Then ctl.BackColor = RGB(150, 180, 215) End If Next ctl طبعا الشرح للمبتدأين أمثالي .. أما لكم أنتم فمن باب " وذكّر ... " 😁

وعليكم السلام ورحمة الله تعالى وبركاته نفضل اخي Private Sub CommandButton2_Click() Dim wbNew As Workbook Dim MH As String, ws As Worksheet Dim val As String Dim shape As Excel.shape MH = CStr(Sheets("الفاتورة").Range("B1")) val = Worksheets("الفاتورة").Range("a14") Application.ScreenUpdating = False Application.DisplayAlerts = False Sheets("الفاتورة").Select Worksheets("الفاتورة").Copy Set wbNew = ActiveWorkbook With Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("a3").Select End With For Each shape In ActiveSheet.Shapes shape.Delete Next Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents Range("A14").Value = val ActiveWorkbook.SaveAs Filename:= _ "C:\Users\edb3\Desktop\" & MH & "-" & "فاتورة رقم" & ".xlsx", FileFormat:=51 ActiveWorkbook.Close Sheets("الفاتورة").Activate Range("b1").Value = Range("b1").Value + 1 Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents Range("a14").Formula = "=NumtoTxt(R[-1]C[6],""جنيهاً"",""قرشاً"")" Range("a3").Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Private Sub CommandButton3_Click() Range("b1").Value = Range("b1").Value + 1 Application.Dialogs(xlDialogPrinterSetup).Show ThisWorkbook.Sheets("الفاتورة").PrintOut copies:=1 Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents End Sub حفظ فاتورة.xlsm

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

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

مثال للتجربة لقد رددت عليك في موضوع سابق ، ارجع له وحاول فهم ملاحظتي . أخي كلنا مررنا بهذه المرحلة فلا تستحي من معاودة وتكرار الاستفهام في نفس الموضوع. ولكي يتجاوب معك أعضاء المنتدى حاول أن ترفق مثالا ، فسوف تسهل المهمة عليك وعليهم. getValue.accdb

تفضل اخي الكريم خلية البحث (G3) 'البحث في عمود A,B Sub ChangeColor() Set MR = Range("A1:B10000") For Each cell In MR If cell.Value = Range("g3") Then cell.Interior.ColorIndex = 6 End If Next End Sub ''''''''''''''''''''''''''''''''''''''''' ' E,البحث عن القيمة في متسلسلة عمود 'وتغيير لون الكتابة Sub FindLoop() Dim strFirstAddress As String Dim rngFindValue As Range Dim rngSearch As Range Dim rngFind As Range Set rngFind = ActiveSheet.Range("E1:E100000") Set rngSearch = rngFind.Cells(rngFind.Cells.Count) Set rngFindValue = rngFind.Find(Range("g3"), rngSearch, xlValues) If Not rngFindValue Is Nothing Then strFirstAddress = rngFindValue.Address rngFindValue.Font.Color = vbRed Do Set rngFindValue = rngFind.FindNext(rngFindValue) rngFindValue.Font.Color = vbRed Loop Until rngFindValue.Address = strFirstAddress End If End Sub 298667823_.xlsm

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

السلام عليكم ورحمة الله تعالى وبركاته تفضل اخي يمكنك اختيار معيار الفلترة في خانة (D1) او ادخاله يدويا لفلترة جميع الاوراق على نفس المعيار Sub Filter_Me() Dim ans As String Dim T As ListObject MH = Sheets("Drawing").Range("D1") For i = 1 To Sheets.Count For Each T In Sheets(i).ListObjects T.Range.AutoFilter Field:=1, Criteria1:=MH Next Next End Sub ''''الغاء الفلترة من جميع الاوراق Sub Remove_Filters_From_Workbook() Dim MH As Worksheet Dim lstObj As ListObject For Each MH In Worksheets For Each lstObj In MH.ListObjects lstObj.AutoFilter.ShowAllData Next lstObj Next MH End Sub New Microsoft Excel Worksheet_MH.xlsm

مع ان الكلام موجه لاخي وصديقي المهندس قاسم نعم ممكن تعديل بسيط على عمل اخي قاسم ولو املك الوقت لقدمت حل بفكره اخرى تغير لون الزر(2)(1).accdb

احسنت اخي قاسم ويمكن التصريح باسم العنصر مباشرة او كما يفعل بعض جيل الطيبين بوضع قيمة العنصر بدون كتابة اسمه acAttachment 126 Attachment control acBoundObjectFrame 108 BoundObjectFrame control acCheckBox 106 CheckBox control acComboBox 111 ComboBox control acCommandButton 104 CommandButton control acCustomControl 119 ActiveX control acEmptyCell 127 EmptyCell control acImage 103 Image control acLabel 100 Label control acLine 102 Line control acListBox 110 ListBox control acNavigationButton 130 NavigationButton control acNavigationControl 129 NavigationControl control acObjectFrame 114 Unbound ObjectFrame control acOptionButton 105 OptionButton control acOptionGroup 107 OptionGroup control acPage 124 Page control acPageBreak 118 PageBreak control acRectangle 101 Rectangle control acSubForm 112 SubForm control acTabCtl 123 Tab control acTextBox 109 TextBox control acToggleButton 122 ToggleButton control acWebBrowser 128 WebBrowserControl control تحياتي

جرب المرفق فقط حددنا الكائن الذي سيتم تطبيق الامر عليه Function SetActiveControlColour() Dim ctl As Control For Each ctl In Me.Controls If ctl.ControlType = 104 Then ctl.BackColor = RGB(150, 180, 215) End If Next ctl Me.ActiveControl.BackColor = vbYellow End Function 104 يعني زر امر الملف مرفق تغير لون الزر(2).accdb

وعليكم السلام دكتور.. تفضل هذا المثال ..وانا اسف لعدم اكمال ماتبقى لاني لست متواجد على طول في الموقع هذه الفترة تغير لون الزر.accdb

وعليكم السلام 🙂 اخي بشار ، اجعل عملية البحث اهم صديق لك في المنتدى ، فستحصل على اجابات سنين ، بدل انتظار الردود على موضوعك 🙂 جعفر

السلام عليكم لم أجرب مثال أخي محمد طاهر ولكني أعتقد أنك بحاجة إلى تغيير تنسيق الخلية إلى رقمي . كما يمكن أن تحصل على المطلوب بدون كود وذلك بضرب الخلية في 24 وتغيير تنسيق الخلية كذلك إلى رقمي . مثلا لو الوقت موجود في خلية A1 ففي خلية أخرى نضع المعادلة التالية : A1*24= تحياتي .

السلام عليكم بعد إذن Sharaf ومحمد طاهر هذا مثال قديم يجسد استخدام الإستهداف آمل أن يكون مفيدا تحياتي . Installments.zip

بعد إذن الأخ أحمد استغليت نفس المثال لاضافة الطريقة بالكود اختار الخلية الهدف ( الصفراء ) ثم شغل الماكرو ( ALT+F8 ) ثم اختار الماكرو و اضغط Run سيسألك عن القيمة المستهدف الوصول اليها ، و يغير أصل الراتب ليصل الصافي الي القيمة التي ستحددها Sub GoolSeekit() Dim x As Double x = InputBox("Please Choose the Value", "Goal Seek Example ", 900) ActiveCell.GoalSeek Goal:=x, ChangingCell:=Range("b4") End Sub