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

السلام عليكم ورحمة الله وبركاته 🌹 درسنا اليوم عن طريقة عمل قوائم ديناميكية متحركة بأقل عدد من الأكواد وطريقة مبتكرة . 🙂 النتيجة النهائية : الشرح : تحميل الملف : Dynamic Menus.accdb

السلام عليكم ورحمة الله وبركاته يسرني اليوم أن أقدم لكم هذه الهدية المتميزة والرائعة (مكتبة الأكواد الخاصة) :: الإصدار الثالث :: مكتبة عامرة بمئات الأكواد VBA داعمة للمبرمجين وجزء لا يتجزأ من عملهم. تختصر الوقت وتسهل العمل على مصممي البرامج. وهي مكتبة عامة يمكن استخدامها لأي لغات برمجية أخرى . من مميزات المكتبة : - أكثر من 360 كود ودالة في مختلف الفنون والمجالات . - قابلة لحفظ مرفقات مع الكود لدعم التطبيق. - يمكنك إضافة أكوادك الخاصة لتكون مكتبة داعمة لكل مبرمج. - سهلة الاستخدام . تحميل المكتبة : مكتبة الأكواد الخاصة zip.zip ولا تنسوني من صالح دعواتكم 🙂🌹

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

تفضل : جمع كل صفحة / ومجموع ما قبله / والمجموع الكلي . اولا تم التجميع على مستوى الاعمدة ثم استخراج الاجمالي حسب المعادلة حقول التجميع تمت تغطيتها بحقول الاجمالي بحيث تختفي تحتها DataFarms.rar

السلام عليكم امتداداً لتطويرات برنامج الخليل المحاسبي يسرني أهدي لكم الإصدار الثاني مع تعديلات وإضافات جميلة كما أشكر أستاذي الفاضل @sandanet لقد استفدت من طريقته في الحماية حسب مشاركته القيمة : اترك لكم البرنامج . وآملاً أن اتلقى ملاحظاتكم القيمة بعد استخدام البرنامج . تقبلوا فائق المحبة والتقدير BuySal20_V14.accdb BuySal20_V14.accdb.mdb.zip

ضع هذا السطر بدل الموجود في حقل الربح ...لكن هذا سيسبب لك مشكلة في قيمة الارباح الربح: IIf([سعر الشراء]=0;0;Abs([سعر البيع]-[سعر الشراء])) العمليات الحسابية وضعتها اكسس في الجدول على سبيل التعلم ...دائما اجري العمليات خارج الجدول

طبعا ممكن ...ولو السؤال غريب الربح.rar

من الواضح أن إجراء التمكين غير موجود والذي يسمى enableply لذلك يمكنك استعمال هذين الاجرائين للتعطيل Private Sub Workbook_Open() Application.CommandBars("Ply").Enabled = False End Sub للتمكين Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.CommandBars("Ply").Enabled = True End Sub بالتوفيق

وعليكم السلام إليك هذه المحاولة New Microsoft Excel Worksheet.xlsx

السلام عليكم نظرا لبعض طلبات الاعضاء الكرام . خاصة ممن يقومون بعمل برامج من أجل كسب العيش أعانهم الله فيما يخص حماية الاكواد التي بملفاتهم لانه عادة ما تحصل سرقة لبرامجهم و هذا بسبب ان أكسل لا يوفر الخماية الكاملة اضافة الى أن هناك برامج تقوم بكشف كلمات سر الملف ببساطة. لذلك اردت أن أقدم فكرة و هي تحويل الكود البرمجي الى ملف DLL مما يوفر حماية قوية للملف عن طريق برنامج vbacompiler for excel و لكن للاسف غير مجاني و هو برنامج يقوم بتحويل الاكواد بالملف الى ملف DLL و تغيير الاكواد بالملف لتستدعى ملف DLL الذي تم انشاؤه و يعمل الملف بكفاءءة عالية لقد قمت بالتجريب و فعلا نتيجة رائعة. يمكنك تحميل البرنامج كنسخة تجريبية . و بالنسبة للذين يعملون البرامج و يبيعونها و يكسبون العيش مننها يمكنهم شراء النسخة الكاملة كيف تحمي ملفك ؟ يمكنك وضع كود خاص بكلمة السر و السريال نمبر للهارد ديسك و ييمكنك وضع الكود التالي عند فتح الملف WORK BOOK OPEN يعني اذاكان رقم السريال نمبر هو مثلا : FFFFF-FFFFF-FFFFF ادخل الرقم السري 222222 و اذا كان خطأا اغلق الملف Private Sub Workbook_Open() Dim RAD As String If CreateObject("Scripting.FileSystemObject").GetDrive("C:\").SerialNumber = "FFFFF-FFFFF-FFFFF" Then RAD = InputBox("Enter password:") If LCaseRAD <> "222222" Then ActiveWorkbook.Close False End If End Sub و بعد الانتهاء من عمل ملف افتح برنامج vbacompiler for excel و جول ملفك الى ملف جديد معه ملف DLL يمكنك التجريب على أي ملف لقد قمت بتجريب البرنامج على ملف أحد الاعضاء و النتيجة بالمرفقات الملف عبارة عن كود بسيط يبحث عن تكرار في عمودين و نقل المكرر الى عمود ثالث هدا الكود مثلا قبل استعمال برنامج vbacompiler for excel Sub brg() ScreenUpdating = False Dim lr As Integer Dim lr1 As Integer Dim c As Range lr1 = ActiveSheet.Range("g" & Rows.Count).End(xlUp).Row For Each c In ActiveSheet.Range("c2:c1000") lr = ActiveSheet.Range("i" & Rows.Count).End(xlUp).Row If WorksheetFunction.CountIf(ActiveSheet.Range("g2:g" & lr1), c.Value) >= 1 Then Cells(lr + 1, 9) = c.Value On Error Resume Next End If Next ScreenUpdating = True End Sub و هذا بعد استعمال البرنامج #If Win64 Then Private Declare PtrSafe Sub p0iflwmc269 Lib "EXEMPLE_xlsm_64.dll" Alias "r8rfyae98n05rlq" () #Else Private Declare Sub p0iflwmc269 Lib "EXEMPLE_xlsm_64.dll" Alias "r8rfyae98n05rlq@0" () #End If Sub brg() p0iflwmc269 End Sub Option Private Module #If Win64 Then Private Declare PtrSafe Function SetThisWbk Lib "EXEMPLE_xlsm_64.dll" Alias "SetThisWorkbook" (ByVal twbk As Object) As Long Private Declare PtrSafe Function u6hpyov9dx5 Lib "EXEMPLE_xlsm_64.dll" (ByVal i As Long, ByVal obj As Object) As Long Private Declare PtrSafe Function c1smc91ey1mls Lib "EXEMPLE_xlsm_64.dll" (ByVal i As Long, ByVal mp As LongPtr) As Long Private Declare PtrSafe Function s1a3nzo1yqora3l Lib "EXEMPLE_xlsm_64.dll" () As Variant Private Declare PtrSafe Sub d0np2x0oglsn Lib "EXEMPLE_xlsm_64.dll" (ByVal dst As Any, ByVal src As LongPtr, ByVal sz As Long) Private Declare PtrSafe Function p8t9c8qi9tgx Lib "EXEMPLE_xlsm_64.dll" (ByRef p() As Any) As LongPtr Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal libFileName As String) As LongPtr Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As LongLong Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr #Else Private Declare Function SetThisWbk Lib "EXEMPLE_xlsm_64.dll" Alias "SetThisWorkbook@4" (ByVal twbk As Object) As Long Private Declare Function u6hpyov9dx5 Lib "EXEMPLE_xlsm_64.dll" Alias "u6hpyov9dx5@8" (ByVal i As Long,ByVal obj As Object) As Long Private Declare Function c1smc91ey1mls Lib "EXEMPLE_xlsm_64.dll" Alias "c1smc91ey1mls@8" (ByVal i As Long,ByVal mp As Long) As Long Private Declare Function s1a3nzo1yqora3l Lib "EXEMPLE_xlsm_64.dll" Alias "s1a3nzo1yqora3l@0" () As Variant Private Declare Sub d0np2x0oglsn Lib "EXEMPLE_xlsm_64.dll" Alias "d0np2x0oglsn@12" (ByVal dst As Any,ByVal src As Long,ByVal sz As Long) Private Declare Function p8t9c8qi9tgx Lib "EXEMPLE_xlsm_64.dll" Alias "p8t9c8qi9tgx@4" (ByRef p() As Any) As Long Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal libFileName As String) As Long Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long #End If Private Function k7wgf46mba0cj8() As String On Error Resume Next k7wgf46mba0cj8 = ThisWorkbook.Path + "\EXEMPLE_xlsm_64.dll" End Function Public Sub p8oi75y3jrid8() #If Win64 Then Dim hModule As LongPtr Dim dllPath As String Dim msg As String On Error Resume Next dllPath = k7wgf46mba0cj8() hModule = LoadLibrary(dllPath) If hModule = 0 Then MsgBox "Cannot load '" & dllPath & "'" ThisWorkbook.Close False Else c1smc91ey1mls 1&, AddressOf u4fw2npwzdn25f4 If SetThisWbk(ThisWorkbook) Then u6hpyov9dx5 3&, Sheet1 u6hpyov9dx5 4&, Sheet2 u6hpyov9dx5 2&, ThisWorkbook ThisWorkbook.Saved = True Else GoTo qpnt End If End If #Else MsgBox "This workbook can work with 64 bit Excel only" ThisWorkbook.Close False #End If Exit Sub qpnt: ThisWorkbook.Close False End Sub Public Sub x1u5slqd9g() On Error GoTo errh SetThisWbk (ThisWorkbook) Exit Sub errh: p8oi75y3jrid8 End Sub Public Function q7uobay8mw() As Boolean On Error Resume Next q7uobay8mw = GetModuleHandle("EXEMPLE_xlsm_64.dll") <> 0& End Function #If Win64 Then Public Function FreeCompiledDll() As LongLong Dim i As Long Do FreeCompiledDll = FreeLibrary(GetModuleHandle("EXEMPLE_xlsm_64.dll")) i = i + 1 Loop While FreeCompiledDll <> 0 And i < 100 End Function #End If Private Sub auto_open() x1u5slqd9g End Sub Private Sub auto_close() #If Win64 Then On Error Resume Next Dim p As Variant ThisWorkbook.Saved = True SetThisWbk Nothing p = s1a3nzo1yqora3l FreeCompiledDll If p <> "" Then Kill p & "cbinrtl.dll" RmDir p End If #End If End Sub Function u4fw2npwzdn25f4(ByVal v7liriqd8 As Variant, ByVal m8g6onrhcrw As Variant, ByVal m7jy4oel As Variant, ByRef j8yhrsbf2() As Variant) As Variant On Error Resume Next Dim sz As Long sz = UBound(j8yhrsbf2) - LBound(j8yhrsbf2) + 1 Select Case sz Case 0 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel) Case 1 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0)) Case 2 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1)) Case 3 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2)) Case 4 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3)) Case 5 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4)) Case 6 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5)) Case 7 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6)) Case 8 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7)) Case 9 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7), j8yhrsbf2(8)) Case 10 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7), j8yhrsbf2(8), j8yhrsbf2(9)) End Select End Function و الملف يعمل بكفاءة جيدة يمكنكم التجربة من المرفقات ملف خاص بعد التشفير ب اوفيس 64 و ملف خاص بعد التشفير ب اوفيس 32 و السلام عليكم و تقبل الله منا و منكم الملف بدون تشفير.rar الملف مشفر مع ملف DLL لنسخة اوفيس 32.rar الملف مشفر مع ملف DLL لنسخة اوفيس 64.rar

وعليكم السلام ورحمة الله وبركاته تفضل Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Me.Frame1.Visible = False End Sub

و ايضا عندما نضطر الى تقسيم جدول وبالتالي يتطلب وجود علاقة 1 الى 1 هذا ما اشرت اليه في ردي السابق ⬇️ العلاقة تكون بين الجداول ولها ثلاث انواع اما الصلة او الضم فلها اربعة انواع داخلي او خارجي او متقاطع او غير متساوي ولكل منها استخدامه وهذه الانواع الاربعة متعلقة بعرض البيانات ومقترنه بالاستعلام او مابني على الاستعلام من نموذج او تقرير او استعلام اخر او قائمة او قوائم مرتبطة ونتوقف هنا وندع الامر لاهل الاختصاص الشايب

المشكلة ليست في الكود المشكلة في تنسيق الخلية ونوع التقويم

السلام عليكم لو عملت باس وورد معقد لمفتاح الشيفت، هل يمكن كسره أيضا؟

ساعة.xlsmتم حل الموضوع و البرنامج 100%

تفضل أخي الكريم هذا ملف لربما أحد الإخوة قد سبقني بوضعه هنا تفقد المكتبات في محرر الـ VBA

وهذا ايضا ما يعتقده اخونا الفاضل شايب فلادخال البيانات اذا كان لدينا بيانات مرتبطة بسجل رئيسي او رئيسي برئيسي او فرعي بفرعي فان الصلة في الاستعلام لا تغني عن العلاقات للتكامل والتتالي والمرجعية اما الصلة بانوعها فلعرض البيانات وفقا لنوع الصلة المستخدمة وبالتالي الصلة في الاستعلام مؤقته ومقترنه بالاستعلام ولا تغني عن العلاقة الدائمة وبالتالي فان تفضيل الربط بعلاقة او صلة يختلف باختلاف الهدف منه والله اعلم اخونا الشايب

أتوقع الحل بدمج دالتي VLOOKUP COUNTIF بهذه الطريقة =IFERROR(VLOOKUP(L2;$R$2:$T$13;2;FALSE)-1+COUNTIF($L2:$L$2;L2);"") ترقيم بشروط1.xlsx

جرب الكود التالي عله يفي بالغرض بإذن الله Sub Test() Dim x, ws As Worksheet, lr As Long, i As Long, j As Long, startSeq As Long, endSeq As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) lr = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row ws.Range("A2:A" & lr).ClearContents For i = 2 To lr j = 0 x = Application.Match(ws.Cells(i, "L").Value, ws.Columns("T"), 0) If Not IsError(x) Then startSeq = ws.Cells(x, "U").Value endSeq = ws.Cells(x, "V").Value Do j = j + 1 ws.Cells(i + j - 1, "A").Value = startSeq If startSeq > endSeq Then ws.Cells(i + j - 1, "A").Value = Empty startSeq = startSeq + 1 Loop Until ws.Cells(i, "L").Value <> ws.Cells(i + j, "L").Value i = i + j - 1 End If Next i Application.ScreenUpdating = True End Sub إذا قمت بحذف صفوف من البيانات سيلزمك تنفيذ الكود من جديد لضبط التسلسل

اساتذتى على رأيان الاول والثانى وهو ما أميل اليه كانت تلك نصائح من استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل مجتمعا ومقرا وموافقا على على كلام استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @jjafferr إقتباس من كلمات وتوجيهات الاستاذ @ابوخليل

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

وعليكم السلام ورحمة الله تعالى وبركاته اليوزرفورم ينقصه عدة اكواد كالتعديل والحدف وبما انك طلبت تصحيح الاكواد الموجودة فقط قم بافراغ اليوزرفورم من الاكواد السابقة وقم بنسخ الاكواد التالية Private Sub CommandButton3_Click() ' بحث Dim sh1 As Worksheet Dim f As Range Set sh1 = Sheet54 lrw = sh1.Cells(Rows.Count, 5).End(xlUp).Row With TextBox11 If .Value = "" Then MsgBox "من فضلك ادخل الاسم الذي تريد البحث عنه يا عم سعد", vbCritical, "تنبيه يا عم سعد": Exit Sub Set f = sh1.Range("E5:E" & lrw).Find(TextBox11.Value, , xlValues, xlWhole, , , False) If Not f Is Nothing Then TextBox1.Value = sh1.Range("C" & f.Row).Value TextBox2.Value = sh1.Range("D" & f.Row).Value TextBox3.Value = sh1.Range("E" & f.Row).Value TextBox4.Value = sh1.Range("F" & f.Row).Value TextBox5.Value = sh1.Range("G" & f.Row).Value TextBox6.Value = sh1.Range("H" & f.Row).Value TextBox7.Value = sh1.Range("I" & f.Row).Value TextBox8.Value = sh1.Range("J" & f.Row).Value TextBox9.Value = sh1.Range("K" & f.Row).Value TextBox10.Value = sh1.Range("L" & f.Row).Value openpic = sh1.Range("M" & f.Row).Value Me.Image1.Picture = LoadPicture(openpic) Me.Image1.Visible = True Else MsgBox "الاسم غير موجود" End If End With End Sub '''''''''''''''''''''''''' Private Sub CommandButton2_Click() ' اظافة Dim ws As Worksheet: Set ws = Sheet54 Dim lastrow As Long lastrow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 With ws ligne = .Cells(.Rows.Count, "C").End(xlUp).Row + 1 End With ws.Cells(ligne, 4) = Me.TextBox2.Text ws.Cells(ligne, 5) = Me.TextBox3.Text ws.Cells(ligne, 6) = Me.TextBox4.Text ws.Cells(ligne, 7) = Me.TextBox5.Text ws.Cells(ligne, 8) = Me.TextBox6.Text ws.Cells(ligne, 9) = Me.TextBox7.Text ws.Cells(ligne, 10) = Me.TextBox8.Text ws.Cells(ligne, 11) = Me.TextBox9.Text ws.Cells(ligne, 12) = Me.TextBox10.Text ws.Range("C10").Value = 1 With ws.Range("C10:C" & lastrow) .Formula = "=Row() - 9" .Value = .Value End With For I = 1 To 11 Me("Textbox" & I) = "" Next I MsgBox "تم حفظ البيانات بنجاح يا عم سعد", vbInformation, "تنبيه يا عم سعد" End Sub ''''''''''''''''''''''''''''''''''''' Private Sub ListBox1_Click() Me.TextBox11.Value = Me.ListBox1.Column(0) Me.ListBox1.Visible = False End Sub Private Sub TextBox11_Change() 'الى الليست بوكس' جلب جملة البحث If Me.TextBox11.Text = "" Then Me.ListBox1.Visible = False Else Me.ListBox1.Visible = True Me.ListBox1.Clear '------------------------------ Dim lrw Set W = Sheet54 lrw = W.Cells(Rows.Count, 5).End(xlUp).Row l = 0 For Each c In Range("e10:e" & lrw) If c Like TextBox11.Text & "*" Then ListBox1.AddItem ListBox1.List(l, 0) = Cells(c.Row, 5).Value l = l + 1 End If Next c End If End Sub Private Sub TextBox11_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then TextBox11.Value = "" End If End Sub محمد (2).xlsm

اعتذر نسيت بالنسبة لسؤال بعد اذن اخى الحبيب ومعلمى القدير الاستاذ @دروب مبرمج شوف يا استاذ @mohamedab557 وركز معايا استاذى الجليل قام بعمل وحدو نمطية لعمل روتين عام اسم هذا الروتين العام هو NewList ولاحظ معى الاتى هناك بين قوسان متغير تم الاعلان هنا باسم SetTop وهو رقم طيب الشكل كاملا لهذا الروتين Function NewList(SetTop As Integer) اذا عند استدعاء الروتين ليقوم بتنفيذ وظيفته لابد ان يكون على النحو الاتى Function NewList( 0 or 1 or 2 or ... or ....) نفهم اذن ان ما بين الاقواس هو متغير رقمى اسند انا اليه القيمة التى اريدها حسب متطلباتى وبما انك تريد ان تكون قيمة ال Top متغيره وتضعها انت من النموذج من واقع مربع النص فيتم استدعاء الوظيقة Function NewList بالشكل التالى NewList(Me.SetNo) وان اعجبت بأفكار استاذى الجليل ومعلمى القدير @دروب مبرمج كما أعجبت أنا بها أكثر من فكرتى انتظر منى تعديلا طفيف جدا جدا جدا بعد إذن استاذى طبعا العفو منكم استاذى الجليل والله اشتجنا

وعليكم السلام في الخلية A2 جرب المعادلة التاليه =SUBTOTAL(103, $L$2:L2)

انا لم استطع فهم المطلوب جيدا وهو جسبا فهمت يحمل معنيين الاول ربط الجداول برمجيا وان كان كذلك / اتفضل هاكم طريقتى فى المرفق اتمنى ان تنال رضاكم الثانى العلاقات بين الجداول : وان كنت تقصد ذلك دعنى اقدم اليكم نصيحة لا تقم بعمل الربط بين الجدول الا داخل الاستعلامات وقت الحاجة وحسب المتطلبات اليها Reink Table.zip

السلام عليكم ومشاركة مع استاذى ومعلمى @دروب مبرمج لانى كنت أفكر فى الحل بأبسط الطرق قمت باستخدام دوال تحويل البيانات لان الحقل المراد التعامل معه حقل نصى ولاننا مستقبلا نريد التعامل مع القيم الرقمية داخل الحقل النصى Sales قمت بعمل استعلام بسيط لتحويل نوع البيانات من نصية الى رقمية من خلال الدالة CLng([sales]) فيكون بناء الاستعلام كالاتى SELECT sales.dname, CLng([sales]) AS FldSales FROM sales; الخطوة الثانية : بعد ذلك الان سوف اتعامل مع هذا الاستعلام وليس الجدول ووضع الكود الاتى على زر الامر على الترتيب الاتى Dim strSQL As String الاعلان عن متغير نصى If IsNull(txtXTop) Or Len(txtXTop) = 0 Then اى ان كان مربع النص txtXTop طول السلسلة النصيه له = 0 اى انه فارغ بدون اى قيم فى هذه الحالة سوف اقوم باسناد جملة الاستعلام البسيط مصدر البيانات الان الى المتغير النصى strSQL strSQL = "SELECT sales.dname, CLng([sales]) AS FldSales FROM sales" اما اذا كان مربع النص txtXTop طول السلسلة النصيه له > 0 اى انه يحتوى على قيم قى هذه الحالة سوف اقوم باسناد جملة الاستعلام الاتية الى المتغير ولكن لان جملة الاستعلام عبارة عن سلسلة نصية سوف اقوم باستخدام دوال تحويل البيانات مرة أخرى ولكن فى هذه المرة اريد تحويل الرقم من مربع النص الى سلسلة نصية لان مربع النص الان هو المتغير الذى يمرر قيمة ال Top لاستكمال صياغة جملة SQL دوى ادنى مشاكل من خلال CStr(txtXTop) قتكون الجملة التى سوق يتم اسنادها بهذا الشكل "SELECT TOP " & CStr(txtXTop) & " * FROM qryData ORDER BY FldSales DESC;" وكانت فكرتى تتمحور حول جعل النموذج يعرض البيانات لذلك سوف اسند الى مصدر بيانات النموذج جملة الاستعلام تبعا للحالة من خلال المتغير Me.RecordSource = strSQL وتم اضافة كود تصيد الاخطاء فى حالة تم استخدام اى شئ يخالف الارقام فى مربع النص على النموذج اعتذر للاطالة واعتذر مسبقا فى جالة وجود اى قصور بسبب محاولتى للابقاء على التصميم دون المساس او التغيير فيه مع محاولة الوصول للنتيجة بأبسط طريق واخيرا المرفق select ( X ) Top.accdb

جرب هذه المعادلة =IF(M4*0.0199<1.99,1.99,IF(M4*0.0199>=0.299*F4,0.299*F4,M4*0.0199)) على اعتبار أن قيمة الصفقة هي الخلية F4 بالتوفيق

لا أدري ما المشكلة عندك على كل اتبع ما هو هو مكتوب في المرفق اوفسينا.xlsm

تفضل اوفسينا.xlsm

يمكنك تجربة هذه المحاولة بالمعادلات بدلا من تصدير النتائج في شيت جديد يمكنك كتابة مصطلح البحث والحصول على النتائج في شيت النتائج أهم شيء معادلة المسلسل في شيت البيانات data لأن معادلة البحث vlookup تعتمد عليها بالتوفيق فلترة نتائج البحث في شيت جديد.xls

أستاذي ومعلمنا العزيز @ابوخليل .. وأنا يشرفني كثيرا أنك أول الحضور والمعلقين 🙂 🌹 عمت الفرحة وزاد الهنا ☺️ أجاب الله دعواتك .. وعمت بركاتك .. ونفعنا الله بك .. وحفك التوفيق والتسديد 🤲🏻

يسرني ان اكون اول المشاركين في الرد وقبل ان اطلع على المرفق يكفي هذه الصورة لتتحدث عن المحتوى ابداعاتك لا تنتهي .. أسأل الله الكريم ان يجعل ما تقدمه لإخوانك من فائدة وخير ؛ سعة لك في الرزق وان يبارك لك في وقتك وأهلك وولدك ----------------- تم الاطلاع عمل جبار يغني عن جميع ما املكه من مكتبات ومراجع

تفضل جرب هذا معدل.xlsm

تم إجراء بعض التعديلات لتتناسب مع المطلوب وهي: كتابة تاريخ 1 في الشهر المطلوب في الخلية c5 وبناء يتم جلب بيانات باقي ايام الشهر وتلوين الجمعة والسبت وكتابة اسم الشهر تلقائيا تم وضع معادلة التصفية الأفقية لجلب تاريخ اليوم المكتوب فيه غ (معادلة مصفوفات) تم وضع معادلة لحساب عدد أيام الغياب بالتوفيق حضور و غياب مع الخلاصة الشهرية.xlsm

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

تم معالجة الامر بالكامل Sub fil_Profname() Application.ScreenUpdating = False Dim p As Worksheet, T As Worksheet, G As Worksheet Dim x%, xx%, m%, how_many%, r%, i%, y%, mun%: num = 1 Dim resl As Range, F_rg As Range Dim Mth As Range, arr(), cel As Range Dim D_arr() Set p = Sheets("P"): Set T = Sheets("T") Set G = Sheets("GHIAB") Set resl = G.Range("a5").CurrentRegion r = resl.Rows.Count If r > 1 Then resl.Offset(1).Resize(r - 1).Clear x = 4: m = 6 Do Until p.Range("a" & x) = vbNullString '====================================== how_many = Application.CountIf(p.Range("D" & x).Resize(, 500), "Ok") If how_many = 0 Then GoTo Next_x Set Mth = G.Range("P12:P23").Find(G.Range("P5")).Offset(, 1) first = Application.Match(Mth, p.Cells(500, "d").Resize(, 250), 0) + 3 y = Application.CountIf(p.Rows(500), Mth) For Each cel In p.Cells(3, first).Resize(, y) If Month(cel) = Mth And UCase(cel.Offset(x - 3)) = "OK" Then ReDim Preserve arr(1 To num) ReDim Preserve D_arr(1 To num) arr(num) = CDate(cel) D_arr(num) = cel.Offset(-1) num = num + 1 End If Next If num > 1 Then G.Cells(m, 1).Resize(num - 1) = Application.Transpose(arr) G.Cells(m, 2).Resize(num - 1) = Application.Transpose(D_arr) For i = 1 To num - 1 G.Cells(m + i - 1, 3) = p.Cells(x, 1) G.Cells(m + i - 1, 4) = p.Cells(x, 2) G.Cells(m + i - 1, 5) = p.Cells(x, 3) Next m = m + num - 1 End If Erase arr: Erase D_arr: num = 1 Next_x: x = x + 1 Loop Set resl = G.Range("a5").CurrentRegion r = resl.Rows.Count If r = 1 Then Exit Sub Set resl = resl.Offset(1).Resize(r - 1) With resl .InsertIndent 1 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 End With MADDA Application.ScreenUpdating = True End Sub '================================ Sub MADDA() Dim T As Worksheet, G As Worksheet Dim x%, xx%, m%, r1% Dim F_rg As Range Set T = Sheets("T") Set G = Sheets("GHIAB") x = 6: m = 6 Do Until G.Range("A" & x) = vbNullString xx = T.Rows(1).Find(G.Range("B" & x)).Column Set F_rg = T.Columns(1).Find(G.Range("C" & x), lookat:=1) If F_rg Is Nothing Then GoTo Next_x r1 = F_rg.Row G.Cells(m, 6).Resize(, 8).Value = _ T.Cells(r1, xx).Resize(, 8).Value m = m + 1 Next_x: x = x + 1 Loop End Sub الملف medSalim_Final.xlsm

من باب العرفان بالجميل واحتراماً لشيء يدعى "حقوق الملكية الفكرية" كان يجب عليك ان تذكر من وضع لك الكود الذي تعمل عليه في الملف تم التعديل على الكود كما تريد Option Explicit Sub ABSCENT_new() Application.Calculation = xlCalculationManual Dim K As Worksheet, A As Worksheet Dim Ro_K%, col%, Ro_A%, i%, m%, t%: t = 1 Dim ALL$, ALPHA$, Str$: Str = "غ" ALL$ = " ": ALPHA = " " Set K = Sheets("keab"): Set A = Sheets("arhkeab") Ro_K = K.Cells(Rows.Count, 2).End(3).Row If Ro_K < 5 Then Exit Sub Ro_A = A.Cells(Rows.Count, 2).End(3).Row m = IIf(Ro_A < 5, 5, Ro_A + 1) For i = 5 To Ro_K If Application.CountIf(K.Cells(i, 6).Resize(1, 31), Str) = 0 Then _ GoTo My_next A.Cells(m, 2).Resize(, 2).Value = _ K.Cells(i, 2).Resize(, 2).Value For col = 6 To 36 If K.Cells(i, col) = Str Then ALL = ALL & Day(K.Cells(4, col)) & "-" ALPHA = ALPHA & K.Cells(3, col) & "-" t = t + 1 End If Next col If t > 1 Then With A.Cells(m, 4) .Value = Mid(ALL, 1, Len(ALL) - 1) .Offset(, 1) = Mid(ALPHA, 1, Len(ALPHA) - 1) .Offset(, 2) = t - 1 .Offset(, 3) = K.Cells(2, "T") .Offset(, 4) = Year(Date) End With m = m + 1 End If My_next: t = 1 ALL = " ": ALPHA = " " Next i Application.Calculation = xlCalculationAutomatic End Sub Tarhil_3iyab (2).xlsm

السلام عليكم ورحمة الله حل بالمعادلات في الملف المرفق... بن علية حاجي استدعاء الغياب.xls

تفضل اخي الغالي =HYPERLINK("#"&"اليومية"&"!"&"d"&COUNTA(مبيع17[[#All];[الاسم Account Name]])+12;"الانتقال إلى آخر صف") ارتباط تشعبي.rar

الحمد لله أن تم المطلوب على خير بالنسبة لملفك أنت أدرى به .. يجب تفحص الملف بشكل جيد وتفحص النتائج للتأكد من صحة سلامة الأكواد ونصيحة حاول دائماً ان يكون للملف الهام لديك نسخ احتياطي وليست نسخة واحدة يعني مع كل تطور بالملف ينصح بعمل نسخة احتياطي حتى إذا حدثت مشكلة ترجع لآخر نسخة سليمة ولا يضيع كل العمل هباء (مفيش حاجة مضمونة)

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

الأخ الحبيب علي الرويلي أكيد ممكن مش ممكن ليه تفضل جرب الكود Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Range("A1:A100,C1:C100,M1:M100")) Is Nothing Then Cancel = True Target.Font.Name = "Marlett" If Target = vbNullString Then Target = "a" Else Target = vbNullString End If End If End Sub

نعم إليك الحل تفضل اسماء الحسابات#3.rar

السلام عليكم بناء على المعلمات المدخلة في شيت الخزينة , سيتم الحساب في الورقة 2 حتى وإن كانت مخفية تفضل اسماء الحسابات#2.rar

السلام عليكم تم استبدال كل المعادلات في الجدول بما فيها sumif وذلك بالاستعانة بالسطرين الأول والثاني من الشيت تفضل خزينة#1.rar

تفضل المرفق 2003 كود زر ترحيل.rar

بسم الله الرحمن الرحيم هنــا شرح لقوائــم اخــرى

بسم الله الرحمن الرحيم الدرس الثالث برنامج المصروفات الشهريه سنقوم فى هذا الدرس باكمال بيانات و معادلات الملف عمود الكود قى صفحه " List " ضع فى الخليه C2الكود التالى =LOOKUP(B2;دمج_الكود;الكود) حيث اننا مجرد اختيار بيانات دمج الكود يظهر لنا الكود تلقائى و لاظهار بيانات عمود البيان نضع الكود التالى =LOOKUP(B2;دمج_الكود;البيان) و قد سبق تعريف مجال البيان و دمج_الكود و طبعا تستطيع استبدال هذا المجال بنطاق خلايا تقوم انت بتحديدها 0 و فى عمود الرصيد ضع الكود التالى =E2-F2 أنظر الصوره و لجمع خانه الرصيد انظر ماذا تفعل القائمه " List " و بنفس الطريقه تستطيع جمع اى عمود بالقائمه الان نذهب الى الورقه " ID " و نضيف عمود للمصروفات المتوقعه خلال الشهر باسم " التقديرى " و عمود ثان يقوم بجمع المصروفات خلال الشهر بورقه " List " ثم توزيع كل مبلغ على الكود المقابل له بورقه : " ID " أكتب الكود التالى بالخليه E2 بالورقه " ID " =SUMIF(List!$C$1:$C$5;ID!A1:A8;List!$I$1:$I$5) اجمع عمود الرصيد ويجب يجب ان يكون مجموع عمود الرصيد بالورقه ID يساوى مجموع عمود الرصيد بالورقه List فخصص خانه لطرح الخليتين و لتكن E11 و هى النقديه الباقيه معك 0 و تستطيع انشاء عمود لحساب الفرق بين التقدير و الفعلى مع مراعاه الاشاره و هذه الصوره النهائيه لورقه " List " و هذه الصوره النهائيه لورقه " ID " و المبلغ الموجود فى خليه المجموع هو النفديه الباقيه معك و يجب ان يساوى خليه المجموع بالورقه " List " هذا برنامج صغير لحساب المصروفات الشخصيه و تستطيع التعديل فيه بالصوره التى تناسبك 0 مرفق ملف نهائى و الى لقاء السلام عليكم Prog_14.rar

بسم الله الرحمن الرحيم الدرس الثانى برنامج المصروفات الشهريه انتهينا فى الدرس الاول من اعداد ورقه للتعريفات الثابته و سنقوم الان باعداد ورقه أدخال البيانات 0 سنقوم بانشاء ورقه جديده و لنسميها “ List” كما بالصوره مع ملاحظه ان الخلايا المظلله باللون الاصفر تتضمن معادلات و الاخضر لادخال البيانات عن طريق القائمه و سيلى شرحها و غير الملونه لادخال البيانات بطريقه عاديه 0 عمود دمج الكود فى هذا العمود سنقوم بانشاء قائمه لاختيار البيانات منها و لكن قبل ان نبدا يجب تحديد المجال المراد اختيار البيانات منه و هو عمود دمج الكود فى ورقه “ ID” سنقوم بتظليله اولا عمود دمج الكود بالوقوف على الخليه C1 حتى يظهر سهم اسود صغير تم انقر اثناء ظهور السهم و تاكد ان التظليل كامل حتى الصف الذى يوجد به النجمه ( اخر سطر ) ثم انظر الصوره و هكذا قمت بتحديد مجال عمود دمج الكود و لاحظ ان هناك _ بين كلمتى دمج و الكود و للتجربه أذهب لاى ورقه ثم قف هنا و اكتب دمج_الكود ستجد انك قد اتجهت الى المجال السابق تحديده , و بهذا يمكن الاستعاضه عن كتابه النطاقات مثل ( C1:C9 ) بكتابه دمج_الكود , مع العلم ان هذا المجال يزداد تلقائى عند اضافه سطر جديد كما سبق و بينا بالدرس السابق 0 ناتى للخطوه التاليه و هى أدخال البيانات عن طريق القائمه قف فى الخليه B1 ثم و هذه الصوره للزياده فى المعرفه لاحظ ما حدث فى عمود دمج الكود و هنا يظهر لنا فائده عمود دمج الكود 0 أنشاء مجالان جدبدان لكل من عمود الكود وعمود البيان مرفق ملف لهذا الدرس و الى لقاء يوم الاحد ان شاء اللهProg_13.rar