كل الانشطه

إخواني الأعزاء بعد سلام الله عليكم ورحمة الله وبركاته في الملف المرفق محتاج عمل استعلام يربط بين جدول (tbl_Exams ) وجدول ( Tbl_student ) لعمل جدول امتحانات في التقرير (namber_galos66 ) بحيث عند فتح فورم ( frm_Reports ) واختيار الفصل الدراسي والفئة ( عليا مثلا ) ثم اختيار الصف ( الرابع مثلا ) ثم الضغط علي زر ( جدول الامتحان ) يتم جلب التقرير ((namber_galos66 ) به جدول الامتحان لعدد 3 تلاميذ أو 4 في كل صفحة أتمني أن أكون وصلت الفكرة ولكم جزيل الشكرData125.rar

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

تفضل أخي ضع الكود التالي في حدث ورقة Sheet1 Option Explicit Dim OnRng As Variant Dim Cnt As Long Dim CrWS As Worksheet Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim dict As Object, lastRow As Long, i As Long, val As String, key As Variant, a As Variant On Error GoTo SupApp If Target.CountLarge > 1 Or Target.Row < 2 Or _ Target.Row > 100 Then ' '<==== هنا قم بتعديل اخر صف لاظهار القوائم بما يناسبك ComboBox1.Visible = False Exit Sub End If If ComboBox1 Is Nothing Then Exit Sub Set CrWS = ThisWorkbook.Sheets("داتا") If CrWS Is Nothing Then Exit Sub Cnt = Target.Column Select Case Cnt Case 3, 4, 5, 9, 10, 11, 15 lastRow = CrWS.Cells(CrWS.Rows.Count, Cnt).End(xlUp).Row If lastRow < 2 Then ComboBox1.Visible = False Exit Sub End If a = CrWS.Range(CrWS.Cells(2, Cnt), CrWS.Cells(lastRow, Cnt)).Value Set dict = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) val = Trim(CStr(a(i, 1))) If val <> "" Then If Not dict.Exists(val) Then dict.Add val, Nothing End If End If Next i If dict.Count > 0 Then ReDim OnRng(1 To dict.Count, 1 To 1) i = 1 For Each key In dict.Keys OnRng(i, 1) = key i = i + 1 Next key Else ReDim OnRng(1 To 1, 1 To 1) OnRng(1, 1) = "" End If With ComboBox1 .List = Application.Transpose(OnRng) .Height = Target.Height + 3 .Width = Target.Width .Top = Target.Top .Left = Target.Left .Value = Target.Value .Visible = True .Activate End With Case Else ComboBox1.Visible = False End Select Exit Sub SupApp: ComboBox1.Visible = False End Sub Private Sub ComboBox1_Change() On Error Resume Next If Me.ComboBox1.Value <> "" Then Dim d1 As Object, i As Long Set d1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(OnRng, 1) If InStr(1, UCase(OnRng(i, 1)), UCase(Me.ComboBox1.Value), vbTextCompare) > 0 Then d1(OnRng(i, 1)) = "" End If Next i If d1.Count > 0 Then Me.ComboBox1.List = d1.Keys Me.ComboBox1.DropDown End If End If ActiveCell.Value = Me.ComboBox1.Value End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then ActiveCell.Offset(1).Select ComboBox1.Visible = False KeyCode = 0 ElseIf KeyCode = vbKeyEscape Then ComboBox1.Visible = False KeyCode = 0 End If End Sub Private Sub ComboBox1_Click() On Error Resume Next If CrWS Is Nothing Then Exit Sub Dim lastRow As Long, xRng As Variant lastRow = CrWS.Cells(CrWS.Rows.Count, Cnt).End(xlUp).Row If lastRow < 2 Then Exit Sub xRng = CrWS.Range(CrWS.Cells(2, Cnt), CrWS.Cells(lastRow, Cnt)).Value If Not IsArray(xRng) Then ReDim tmp(1 To 1, 1 To 1) tmp(1, 1) = xRng xRng = tmp End If Me.ComboBox1.List = Application.Transpose(xRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub تعديل .xlsm

عاشت ايدك استاذ حاليا استطيع اضافة الى غاية فرضا ٨٠٠٠ في العمود A وبمجرد سحب المعادلات تظهر النتائج

ببساطة أخي @زياد الحسناوي بعد إضافة الأرقام الجديدة لم تقم بسحب المعادلات للأسفل كما تمت الإشارة إليه في المشاركة السابقة وذلك لأنني قمت بوضع المعادلة على الملف المرفق بقدر البيانات الموجودة سابقا فقط هناك كدالك نقطة مهمة يجب الإنتباه إليها في المعادلة المقترحة =IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A)))), ROWS(D$2:D2)), "") وظيفتها إظهار الأرقام المفقودة من تسلسل يبدأ من 1 حتى أكبر رقم موجود في العمود A وتعرض النتيجة في العمود D أو B حسب وضعها كما جاء في طلبك لكن هذه الصيغة تفترض أن الأرقام تبدأ من 1 وتتزايد بواحد مثال عندما تكون الأرقام بهذا الشكل مثلا فالصيغة أعلاه لن تعمل كما يجب لأنها تبدأ بالبحث من الرقم 1 بينما الأرقام الفعلية تبدأ من 15 لحل هذا الإشكال نقترح استخدام الصيغة التالية التي تعتمد على أصغر وأكبر رقم موجودين فعليا في العمود A =IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A))) ), ROWS(D$2:D2)), "") المعادلة تبحث عن جميع الأرقام بين MIN و MAX وتستبعد الأرقام الموجودة فعليا في العمود A أي ترجع فقط الأرقام المفقودة في تسلسل منتظم وتعرض النتائج بشكل ديناميكي في العمود D بدءا من D2 ارقام مفقودة 3.xlsb

شكرا لك اخي سوف يتم تجربة الكود المرسل منك , ثم سوف اعود اليكم و اخباركم بما سيحدث معي

وعليكم السلام ورحمة الله وبركاته 🤗.. جرب هذا التعديل أخي الكريم :- Private Sub Workbook_Open() Dim filePath As String ' المسار الكامل للملف filePath = "C:\Program Files\new\officeteam.txt" ' تحقق من وجود الملف If Dir(filePath) = "" Then MsgBox "ليس لديك الاذن في الاستخدام, يرجى التواصل مع مالك النظام . تنبيه.", vbCritical ThisWorkbook.Close SaveChanges:=False End If End Sub المشكلة أن الكود الذي كتبته يحتوي على خطأ في طريقة تحديد المسار ، حيث إنك قمت بدمج filePath مع requiredFile مرتين .

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

تفضل :- القاعدة 2.zip

أسعدك الله وبارك الله بك ، وهنأك بعلمه الذي علمك إياه .. وأتمنى لك المزيد من التوفيق والتألق بأعمالك المميزة التي نريد رؤيتها قريباً شكراً لك

السلام عليكم ورحمة الله وبركاته المطلوب حسب ما فهمت هو : إضافةً إلي ما يفعلة إستعلام التحديث الحالي انت تريد تحديث العمود G N بأخر رقم موجود في جدول الجرد تفضل أخي الكريم جرب هذا الكود Public Function arTableName() As String arTableName = ChrW(1580) & ChrW(1583) & ChrW(1608) & ChrW(1604) & ChrW(32) & _ ChrW(1578) & ChrW(1587) & ChrW(1580) & ChrW(1610) & ChrW(1604) & ChrW(32) & _ ChrW(1575) & ChrW(1604) & ChrW(1603) & ChrW(1578) & ChrW(1576) End Function Private Sub أمر8_Click() Dim arTblName As String Dim maxGN As Long Dim arMsgPrompt As String Dim arMsgTitle As String Dim msgResponse As VbMsgBoxResult On Error GoTo ErrorHandler arTblName = arTableName maxGN = Nz(DMax("[No_Gard]", "[T_Gard]"), 0) arMsgTitle = "تأكيد تنفيذ الأمر" arMsgPrompt = "أنت على وشك تحديث حالة جميع الكتب باليومية" arMsgPrompt = arMsgPrompt & vbCrLf & "من كتب موجودة إلى كتب فاقد" arMsgPrompt = arMsgPrompt & vbCrLf & "لتأكيد الأمر أضغط موافق ، ولإلغائه أضغط إلغاء" msgResponse = MsgBox(arMsgPrompt, vbQuestion + vbOKCancel + vbMsgBoxRight, arMsgTitle) strSQL = "UPDATE [" & arTblName & "]" & vbCrLf & _ " SET [" & arTblName & "].CaseBook = ""فاقد""," & vbCrLf & _ " [" & arTblName & "].[G N] = " & maxGN & vbCrLf & _ " WHERE ((([" & arTblName & "].CaseBook)=""موجود"")" & vbCrLf & _ " AND (Not ([" & arTblName & "].title) Is Null)" & vbCrLf & _ " AND (([" & arTblName & "].searinumber) Between [forms]![F_GardBooks]![text]" & vbCrLf & _ " AND [forms]![F_GardBooks]![text2]))" & vbCrLf & _ " OR ((([" & arTblName & "].CaseBook)=""موجود"")" & vbCrLf & _ " AND (([" & arTblName & "].title) Is Null)" & vbCrLf & _ " AND (([" & arTblName & "].searinumber) Between [forms]![F_GardBooks]![text]" & vbCrLf & _ " AND [forms]![F_GardBooks]![text2]));" If msgResponse = vbOK Then DoCmd.SetWarnings False DoCmd.RunSQL strSQL DoCmd.SetWarnings True MsgBox "تم تحديث البيانات بنجاح والحمد لله" Else End If Exit Sub ErrorHandler: Debug.Print Err.Number; Err.Description End Sub تم إضافة هذه الوظيفة {arTableName} لتعود بإسم الجدول العربي أنصح بإستخدامها كما تم تنسيق الكود قليلاً وإضافة { " [" & arTblName & "].[G N] = " & maxGN } لإضافة التحديث المطلوب إضافة بالنسبة للأستعلام الموجود بأسم {استعلام1} Nz(DMax("[No_Gard]", "[T_Gard]"), 0) (SELECT Max(T_Gard.No_Gard) FROM T_Gard) بالتوفيق

السلام عليكم جميعا لدي ملف اكسل و اريد عدم سرقته و فتحه في اي جهاز اخر . استخدمت الكود التالي لكنه في كل مرة تظهر لي رسالة التنبه الموجودة في الكود بالرغم من وجود الملف في المسار المحدد له في الكود ارجو منكم ( من اصحاب الخبرة والفكر النير ) مساعدتي في حل هذه المشلكة اما تصحيح الكود او التكرم ببرمجة كود اخر يمنع فتح ملف الاكسل المحدد الا بوجود ملف معين في مسار معين , ولكم من جزيل الشكر والتقدير هذا هو الكود الذي معي في الوقت الحالي لكنه لا يعمل بشكل صحيح: Private Sub Workbook_Open() Dim requiredFile As String Dim filePath As String ' حدد المسار والملف المطلوبين filePath = "C:\Program Files\new\officeteam.txt" requiredFile = "officeteam.txt" ' تحقق من وجود الملف If Dir(filePath & "\" & requiredFile) = "" Then MsgBox "ليس لديك الاذن في الاستخدام, يرجى التواصل مع مالك النظام . تنبيه.", vbCritical ThisWorkbook.Close SaveChanges:=False End If End Sub

وين كانت المشكلة

اللهم بارك فيه وفي علمه وعمله وأجعل عمله خالصاً لك وحدك يارب العالمين اللهم زد وبارك مبارك عليك أخي فادي @Foksh ماشاء الله تبارك الله أعمالك مميزة وجميلة زادك الله حرصاً وإتقاناً بالتوفيق ❤️

@ابو جودي آمين بارك الله فيك، و شكراً جزيلاً لك أخي الكريم اللهم أرضَ عن عبدك وثبته علي دينك @عاشق_الرقي آمين بارك الله فيك، ورزقك علماً نافعاً ينتفع به وأسئل الله العلي القدير أن ينعم عليك ويزيدك من فضله @عمر ضاحى بارك الله فيك وفي علمك وعملك شكراً جزيلاً

ارجو ان تساعدوني في هذا الموضوع

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

السلام عليكم ورحمة الله وبركاته استاذ محمد هشام تحية طيبة وبعد محتاج اعمل vba نفس اللي حضرتك عامله بس محتاج تعديل علي الشيت المرفق كمثال ان عمود ال c ياخذ من عمود ال c في شيت الداتا وعمود ال d باخذ من عمود ال d في شيت الداتا وعمود ال e باخذ من عمود ال e في شيت الداتا وعمود ال i باخذ من عمود ال i في شيت الداتا وعمود ال j باخذ من عمود ال j في شيت الداتا وعمود ال k باخذ من عمود ال k في شيت الداتا وعمود ال o باخذ من عمود ال o في شيت الداتا وهكذا بنفس الطريقة اللي حضرتك عملت بيها الشيت او الشرح السايق اللي حضرتك عامله تعديل .xlsm

@jjafferr

jjafferr@

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

اوه اخي @Foksh مبارك لك المنصب الجديد 🌹🌹🌹🌹🌹 كنت اسأل متى هيتم ترقيتك لانك سباق دائما ومبدع 🌹🌹🌹 الف الف مبروك اخي فادي

استاذ @Ahmos مبارك لك اضمامك للاسره الكريمه 🌹🌹🌹🌹 الف مبروك 🌹🌹🌹🌹

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

ههههههههه كثروا في النكاش والتناكش فالمستفيد في النهاية (المستهلك ) إللي هوا إحنا طبعاً زادكم الله من فضله وبارك في علمكم