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

السلام عليكم جربت الكود أحمد -إبراهيم -إسلام -آية- أيمن - الادارية-الإدارية - ادارة سميرة -شئ - وغيرهاكلها يالهمز وبدون همز شغال 100% الكود بقوم بالتغاضى عن : جمبع حروف الالف لاي كلمة بالقتح او بالكسر يتم البحث عنها سواء كتبتها بالهمز او بدونه جمبع حروف الياء لاي كلمة عند البحث لو كتبنها الف مقصورة ى يتم احضار قيمتها كذلك كلمة شئ مثلا او ما في حكمها عند البحث لو كتبنها شى بدون همزة يتم احضار قيمتها كذلك اي كلمة فيها ة عند البحث لوكتبتها ه يتم احضار قيمتها وسواء كان الحروف السابقة كانت في اي موقع من الكلمة في بداية او وسط او نهاية الكلمة يقوم باحضار قيمتها كذلك اذا كانت الكلمة حروفها لا تتكرر مع كلمة اخرى مثلا كلمة إبراهيم لو كتبت في البحث هيم يحضر قيمتها كذلك الكود مرن يمكن اظافة اي حروف للكود تريد اهمالها عند البحث str = Replace(str, "أ", "ا") str = Replace(str, "إ", "ا") str = Replace(str, "آ", "ا") str = Replace(str, "ي", "ى") str = Replace(str, "ئ", "ي") str = Replace(str, "ة", "ه") ارفق لك الملف مرة اخرى ولم اغير شيئا بالكود اصدار الاوفيس لدي 2016 وحسب علمى الكود متوافق مع كل الاصدرات بحث حتى لو فى اخلاتف بسيط1.xls

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

هل جربت استخدام هذه الاداة ... barcodex.ocx

السلام عليكم لقد طال غيابي لاسباب يعلمها الله حبيت اضيف شيء بسيط للاستفادة كلنا يعلم ان عقول الناس غير متشابهة البرمجة هي فن وعلم يتطلب مهارات وتقنيات متقدمة لتحويل الأفكار إلى تطبيقات وبرمجيات تعمل على الأجهزة الإلكترونية. إلا أن الطريق الذي يسلكه الشخص في تعلم البرمجة قد يختلف بشكل كبير بين الهاوي والمحترف. الهاوي: الهاوي هو الشخص الذي يدخل عالم البرمجة بدافع الفضول أو الهواية. قد يبدأ في تعلم البرمجة من خلال مشاهدة دروس على الإنترنت أو تجربة برامج مفتوحة المصدر. غالبًا ما يكون هدفه هو فهم أساسيات البرمجة أو إنشاء مشاريع صغيرة لأغراض شخصية أو ترفيهية. قد لا يمتلك الهاوي الخبرة الكافية في بناء تطبيقات معقدة أو التعامل مع المشاكل التقنية الكبيرة. يستخدم الأدوات الأساسية ويبحث عن حلول سهلة عبر الإنترنت دون التعمق في التفاصيل الدقيقة وهده هديتي الى كل هاوي ليس لديه وقت للبحث و دراسة اساسيات البرمجة الموقع الذي يعرفه أغلب الناس تقريبًا، حيث يمكنك طرح السؤال وستحصل على الإجابة، أو يمكنك نسخ الكود البرمجي وتمريره، وستجد أن الموقع قد قام بتصحيح الكود بشكل مباشر. بدون تعب أو انتظار أيام للحصول على الحل. هذا هو الذكاء الاصطناعي. الخدمة المجانية محدودة بعدد الأسئلة، لكن الهدف قد تحقق https://chatgpt.com/

الله يبارك في عمرك بشمهندس محمد هشام ، متشكر جدا لسعة صدرك 🌹

العفو أخي @ahmed sewelam يسعدنا أننا إستطعنا مساعدتك ' تحويل القيمة المدخلة الى تاريخ MinDate و MaxDate MinDate = CDate(TextBox1.Value) MaxDate = CDate(TextBox2.Value) ' جلب البيانات من النطاق A3:I a = WS.Range("A3:I" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value ' قواميس لتخزين البيانات المجمعة ' dc لتخزين صافي المبيعات، dnc لتخزين صافي المردودات، dnc1 لتخزين المندوب Set dc = CreateObject("Scripting.Dictionary") Set dnc = CreateObject("Scripting.Dictionary") Set dnc1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) 'MinDate و MaxDate إذا كان التاريخ ' (العمود B) a(i, 2)' 'يقع بين If a(i, 2) >= MinDate And a(i, 2) <= MaxDate Then tmp = Trim(a(i, 7)) ' العمود G: "المندوب" ' إذا لم يكن المندوب موجودا مسبقا في القاموس نقوم بإضافته وتخزين القيم المبدئية If Not dc.Exists(tmp) Then dnc1(tmp) = a(i, 6) ' العمود F: "تخزين اسم المندوب" dc(tmp) = a(i, 8) ' العمود H: "تخزين صافي المبيعات" dnc(tmp) = a(i, 9) ' العمود I: "تخزين صافي المردودات" Else ' إذا كان المندوب موجودا إضافة القيم إلى القيم المخزنة dc(tmp) = dc(tmp) + a(i, 8) ' تجميع عدد المبيعات dnc(tmp) = dnc(tmp) + a(i, 9) ' تجميع المردودات End If End If Next i 'إذا كانت القواميس تحتوي على بيانات (dc.Count > 0) ' مطابقة للفترة الزمنية المحددة If dc.Count > 0 Then Application.ScreenUpdating = False 'مسح أي محتوى سابق من النطاق C12:F في ورقة "Report" With dest.Range("C12:F" & dest.Rows.Count) .ClearContents .ClearFormats End With ' تعيين حجم المصفوفة arr بناءا على عدد العناصر في القاموس dc n = 1 ReDim arr(1 To dc.Count, 1 To 4) ' تعبئة المصفوفة For Each key In dc.Keys arr(n, 1) = dnc1(key) ' العمود الأول في arr: "كود" arr(n, 2) = key ' العمود الثاني : "المندوب" arr(n, 3) = dc(key) ' العمود الثالث : "إجمالي المبيعات" arr(n, 4) = dnc(key) ' العمود الرابع : "إجمالي المردودات" n = n + 1 Next key ' نسخ محتويات المصفوفة "Report"(C12) بداية من الخلية dest.Range("C12").Resize(dc.Count, 4).Value = arr ' تحديد الصف الأخير المستخدم بعد إدراج البيانات lastRow = dest.Cells(dest.Rows.Count, "E").End(xlUp).Row ' إضافة "الإجمالي" في العمود D أسفل البيانات dest.Cells(lastRow + 1, "D").Value = "الإجمالي" 'وضع الإجمالي أسفل التقرير ' للأعمدة E و F (صافي المبيعات وصافي المردودات)' For Each col In Array("E", "F") dest.Cells(lastRow + 1, col).Value = Application.WorksheetFunction.Sum(dest.Range(col & "12:" & col & lastRow)) Next col ' يتم وضع تاريخ البداية والنهاية في الخلايا E9 و F9 dest.Range("E9").Value = MinDate dest.Range("F9").Value = MaxDate ' نطاق البيانات في التقرير Set Rng = dest.Range("C12:F" & lastRow) ' إضافة حدود حول كل صف في التقرير يحتوي على بيانات For Each C In Rng.Rows If Application.WorksheetFunction.CountA(C) > 0 Then C.Borders.LineStyle = xlContinuous End If Next C

الخلل بسيط بسبب اني غيرت في مسميات بعض الحقول كونها تتشابه في الجدولين تم الضبط والاصلاح baseM_7 .rar

ما شاء الله لا قوة إلا بالله ابداع متواصل وجهد مشكور

سلمت يداك أخى الكريم على ابداعاتك

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور png او حسب خيال المسخدم - تم ضبط كواد التوسيط للنماذج والتقارير باحترافية ويعمل التوسيط مع الخاصية Pop Up فى اى وضع كانت فى حالة عدم استخدام الاخفاء - تم حل مشكلة عدم ظهور التقاربر عند الاخفاء بتكبير التقرير تلقائيا عند استخدام كود الاخفاء - امكانبة التصغير للتطبيق بجوار الساعة ( System Try ) - عند التصغير بجوار الساعة ممكن الضغط كليك يمين على الايقونة لتظهر قائمة اختيارات - تم ضبط كود تغير ايقونة الاكسس باحترافية وبشكل تلقائى من المسار المحدد او فى حالة عدم وجود الايقونة ترجع ايقونة الاكسس - تم التعامل مع الاكواد بحرفية تامة للعمل على بيئات الأنوية المختلفة سواء كانت 32 , 64 اترككم مع تجربة شيقة ملاحظة هامة : ارضاء للجميع ولاضفاء اكبر قدر ممكن من المرونة المرفق يحتوى على قاعدتان الاولى : تم تجميع كل الاكواد والدوال فى وحدة نمطية عامة واحدة وكلاس موديول واحد لسهولة الاستفادة منها ونقلهم الى اى قاعدة الثانية : فصل اكواد كل وظيفة على حدة فى مديول خاص بها تم اضافة تعديل وتحديث جديد بتاريخ 11/10/2024 رقم اصدار التعديل الاخيــر : 4.8 center and Hid and Tray Minimizer V 30.zip center and Hid and Tray Minimizer V 4.8.rar

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

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Sub CommandButton1_Click() Dim MinDate As Date, MaxDate As Date Dim WS As Worksheet, dest As Worksheet Dim a As Variant, tmp As String Dim dc As Object, dnc As Object, dnc1 As Object Dim arr() As Variant, n As Long, lastRow As Long, i As Long Dim Rng As Range, C As Range, col As Variant, key As Variant Set WS = Sheets("DATA"): Set dest = Sheets("Report") If Not IsDate(TextBox1.Value) Or Not IsDate(TextBox2.Value) Then MsgBox "المرجوا التحقق من التواريخ", vbExclamation Exit Sub End If MinDate = CDate(TextBox1.Value) MaxDate = CDate(TextBox2.Value) a = WS.Range("A3:I" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value Set dc = CreateObject("Scripting.Dictionary") Set dnc = CreateObject("Scripting.Dictionary") Set dnc1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) If a(i, 2) >= MinDate And a(i, 2) <= MaxDate Then tmp = Trim(a(i, 7)) If Not dc.Exists(tmp) Then dnc1(tmp) = a(i, 6): dc(tmp) = a(i, 8): dnc(tmp) = a(i, 9) Else dc(tmp) = dc(tmp) + a(i, 8): dnc(tmp) = dnc(tmp) + a(i, 9) End If End If Next i If dc.Count > 0 Then Application.ScreenUpdating = False With dest.Range("C12:F" & dest.Rows.Count) .ClearContents: .ClearFormats End With n = 1 ReDim arr(1 To dc.Count, 1 To 4) For Each key In dc.Keys arr(n, 1) = dnc1(key): arr(n, 2) = key: arr(n, 3) = dc(key): arr(n, 4) = dnc(key) n = n + 1 Next key dest.Range("C12").Resize(dc.Count, 4).Value = arr lastRow = dest.Cells(dest.Rows.Count, "E").End(xlUp).Row dest.Cells(lastRow + 1, "D").Value = "الإجمالي" For Each col In Array("E", "F") dest.Cells(lastRow + 1, col).Value = Application.WorksheetFunction.Sum(dest.Range(col & "12:" & col & lastRow)) Next col dest.Range("E9").Value = MinDate: dest.Range("F9").Value = MaxDate Set Rng = dest.Range("C12:F" & lastRow) For Each C In Rng.Rows If Application.WorksheetFunction.CountA(C) > 0 Then C.Borders.LineStyle = xlContinuous End If Next C Else MsgBox "لا توجد بيانات تطابق التواريخ المحددة" End If Application.ScreenUpdating = True End Sub TEST v1.xlsm

أخي الكريم @Foksh شكراً لك علي النصيحة بارك الله فيك أخي الكريم @Moosak أشكرك لك مرورك الطيب كنت بالفعل أنوي تجهيز الأكواد ومشاركتها بمواضيع منفصة ليسهل البحث عنها ولكن تفضل الأكواد التالية للنقطة 1 وإن شاء الله قريباً النقطة 2 روابط للمراجعة : - https://learn.microsoft.com/en-us/microsoft-365/troubleshoot/administration/enable-disable-hyperlink-warning - https://www.slipstick.com/how-to-outlook/disable-unsafe-hyperlink-warning-opening-attachments/ الأكواد بالموديول هي: * hyperLinkWOn - لتفعيل إشعارات الحماية * hyperLinkWOff - لتعطيل إشعارات الحماية * isHyperLinkW - إذا كانت القيمة DisableHyperlinkWarning موجودة بالمسار وتساوي 0 او غير موجودة فهذا يعني ان الحماية مفعلة * msOfficeSecurityPath - لتعود بالمسار المطلوب داخل الريجيستري * awsLink - يقوم هذا الإجراء بتعطيل الحماية ومن ثم فتح الرابط ثم إعادة تفعيلها مرة أخري قمت بالامر هكذا حتي لا نترك الحماية معطلة ولكن يمكن التعديل علي الكود بحيث يتعرف اولاً علي حالة الحماية وإعادتها لحالتها بعد الإنتهاء Option Compare Database Option Explicit Private Const debugState As Boolean = True Private Const msgLogState As Boolean = False Sub Test_awsLink() Dim sPath As String On Error GoTo ErrorHandler sPath = "whatsapp://send/?phone=+2012312313" ' Fisrt Test When The Warning is Enabled hyperLinkWOn ' Make Sure it's Enable Call Application.FollowHyperlink(sPath) ' Second Test When The awsLink it Automatically turnOff then follow The link Then turnOn Again awsLink sPath ExitAndClean: Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub Public Sub awsLink(ByVal sLink As String) Dim msgRes As VbMsgBoxResult On Error GoTo ErrorHandler hyperLinkWOff ' To Disable The Hyper Link Security Warning If Not (isHyperLinkW) Then Call Application.FollowHyperlink(sLink) Else msgRes = MsgLog("Something Went Wrong" & vbCrLf & _ "We are unable To Disable The Hyper Link Security Warning" & vbCrLf & _ "Do You Want to Continue ?", llQuestion, debugState, msgLogState, , , mbYesNo, db2Second, SecToMs(15)) If msgRes = vbNo Then GoTo ExitAndClean Else Call Application.FollowHyperlink(sLink) End If End If hyperLinkWOn ' To Enable The Hyper Link Security Warning ExitAndClean: Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub Public Sub hyperLinkWOn() Dim winReg As awsReg Dim sPath As String Dim sValue As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = msOfficeSecurityPath Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER .key = sPath .value("DisableHyperlinkWarning") = CInt(0) End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub Public Sub hyperLinkWOff() Dim winReg As awsReg Dim sPath As String Dim sValue As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = msOfficeSecurityPath Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER .key = sPath .value("DisableHyperlinkWarning") = CInt(1) End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub ' isHyperLinkW return True if the DisableHyperlinkWarning is not Exist or = 0 Public Function isHyperLinkW() As Boolean Dim winReg As awsReg Dim sPath As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = msOfficeSecurityPath Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER If Not (.IsKeyExists(sPath)) Then GoTo ExitAndClean .key = sPath If .IsValueExists("DisableHyperlinkWarning") = True Then vResult = .value("DisableHyperlinkWarning") ' Debug.Print vResult(0) ' Debug.Print vResult(1) ' Debug.Print CBool(vResult(0)) If CInt(vResult(0)) = 0 Then isHyperLinkW = True Else isHyperLinkW = False End If Else isHyperLinkW = True End If End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Function ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description & vbCrLf & _ "Source : " & Err.Source _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Function Public Function msOfficeSecurityPath() As String msOfficeSecurityPath = "Software\Microsoft\Office" & "\" & MsAccessVersion() & "\Common\Security" End Function Private Function MsAccessVersion() As String Dim ver As String ver = Application.Version Select Case Left$(ver, 2) Case "16" MsAccessVersion = "16.0" ' Access 2016/2019/365 Case "15" MsAccessVersion = "15.0" ' Access 2013 Case "14" MsAccessVersion = "14.0" ' Access 2010 Case "12" MsAccessVersion = "12.0" ' Access 2007 Case Else MsAccessVersion = ver End Select End Function

وعليكم السلام ورحمة الله تعالى وبركاته اظافة الى ما تقضلو به اساتذتنا الاكارم TEST CODE1.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Sheet1") Dim n As Object: Set n = CreateObject("Scripting.Dictionary") Dim i As Long, ling As Long, lastRow As Long, tmp As String, kay As String, j As Variant If Not Intersect(Target, WS.Range("A4:B" & WS.Rows.Count)) Is Nothing Then Application.ScreenUpdating = False With WS ' مسح النتائج السابقة .Range("I3:J" & .Rows.Count).ClearContents lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ling = 3 ' تحديد صف وضع النتائج ' بداية من الصف 4 For i = 4 To lastRow tmp = .Cells(i, 1).value ' الحصول على القيمة من عمود A kay = .Cells(i, 2).value ' الحصول على القيمة من عمود B ' التأكد من أن القيم ليست فارغة If tmp <> "" And kay <> "" Then If n.Exists(tmp) Then n(tmp) = n(tmp) & ", " & kay Else n.Add tmp, kay End If End If Next i For Each j In n.Keys .Cells(ling, 9).value = j ' القيم الفريدة في عمود I .Cells(ling, 10).value = n(j) ' القيم المرتبطة في عمود J ling = ling + 1 Next j ' تعديل عرض العمود ليتناسب مع المحتوى .Columns("J").AutoFit End With Application.ScreenUpdating = True End If End Sub TEST CODE.xlsb

وعليكم السلام ورحمة الله وبركاته حسب المعادلة في ملفك يمكن استبدالها بمعادلة اخرى لها نفس المهام =SUMPRODUCT(C4:AA4; C$3:AA$3) طبعا لا يمكن لصقها مكان معادلة الصفيف الا بطريقة تظلبل معادلات الصفيف في العمود بالكامل ثم مسح البيانات تم لصق المعادلة الملف المصنف1.xlsx

وعليكم السلام Function JoinUniqueValues(lookupValue As Variant, lookupRange As Range, returnRange As Range) As String Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") Dim i As Long Dim result As String ' إنشاء قاموس لتخزين القيم الفريدة For i = 1 To lookupRange.Count If lookupRange.Cells(i, 1).Value = lookupValue Then If Not dict.exists(returnRange.Cells(i, 1).Value) Then dict.Add returnRange.Cells(i, 1).Value, Nothing End If End If Next i ' دمج القيم الفريدة باستخدام فاصلة result = Join(dict.keys, ", ") JoinUniqueValues = result End Function لاستخدام هذا الكود، قم بإضافته إلى وحدة VBA في Excel، ثم استخدم الدالة في ورقة العمل كالتالي: =JoinUniqueValues(I3, $A$4:$A$1200, $B$4:$B$1200) TEST CODE.xlsm

استاذى الفاضل قمت بنقل النموذج الى برنامجى واعطى هذة الرسالة