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

وعليكم السلام ورحمة الله وبركاته لا يتم عمل باسورد على الجداول ولكن يمكن التحكم في النموذج المرتبط بجدول عند فتحه بكلمة سر كالتالي If InputBox("الرجاء ادخال كلمة السر لفتح النموذج", "فتح النموذج") = "123" Then DoCmd.OpenForm "frm1" Else MsgBox "عفوا .. كلمة السر خاطئة ", vbOKOnly + vbCritical, "خطأ في كلمة السر" DoCmd.Close acForm, "frm1" End If تحياتي

Sub Test() Dim r As Range, c As Range, cel As Range, x As Long Application.ScreenUpdating = False Application.EnableEvents = False Set r = Range("E3:E" & Cells(Rows.Count, "E").End(xlUp).Row) Set c = Range("H5") Set cel = Range("L1") cel.CurrentRegion.ClearContents Do With cel .Offset(1).Resize(r.Rows.Count).Formula = "=SumSolver(" & r.Address & ", " & c.Address & ", " & x + 1 & ", Row(A1))" If .Offset(1).Value = "" Then Exit Do x = x + 1 .Value = x Set cel = cel.Offset(, 1) End With Loop Until x = 100 Application.EnableEvents = True Application.ScreenUpdating = True End Sub Function SumSolver(numbers, t As Double, Optional pt As Long = 1, Optional s As Long = 1) Dim i&, ii!, p&, n(), w, r# If pt < 1 Or s < 1 Then SumSolver = CVErr(xlErrNum): Exit Function w = Split(Application.Trim(Replace(Replace("|" & Join(Application.Transpose(numbers), "||") & "|", "|0|", "|"), "|", " ")), " ") ReDim n(1 To UBound(w) + 1) For ii = 1 To 2 ^ (UBound(w) + 1) - 1 For i = 1 To UBound(w) + 1 n(i) = (Int(ii / 2 ^ (i - 1)) Mod 2) * w(i - 1) r = r + n(i) Next i If Val(r) = Val(t) Then p = p + 1: If pt = p Then Exit For r = 0 Next ii w = Split(Application.Trim(Replace(Replace("|" & Join(n, "||") & "|", "|0|", "|"), "|", " ")), " ") If pt > p Or s > UBound(w) + 1 Then SumSolver = "" Else SumSolver = Val(w(s - 1)) End Function The UDF SumSolver taken from this link http://excel-egy.com/forum/t2787

هذه معادلة البحث بشرطين باستخدام index match إن شاء اللّه تكون المطلوب بالتوفيق اظهار الاستقطاع على اساس الرقم التعريفي ورقم المستند.xlsx

راجع هذا الموضوع ربما تجد ماتبحث عنه

لإثراء الموضوع تفضل اخري الكريم Private Sub السيارة_جاهزة_Click() If Me.السيارة_جاهزة = True Then Me.السيارة_مغادرة = False End Sub Private Sub السيارة_مغادرة_Click() If Me.السيارة_مغادرة = True Then Me.السيارة_جاهزة = False End Sub او Private Sub السيارة_جاهزة_Click() Select Case Me.السيارة_جاهزة Case Me.السيارة_جاهزة = True Me.السيارة_مغادرة = False End Select End Sub Private Sub السيارة_مغادرة_Click() Select Case Me.السيارة_مغادرة Case Me.السيارة_مغادرة = True Me.السيارة_جاهزة = False End Select End Sub تحياتي

تفضل >>>>>> warehouse3.accdb

نعم تعمل لكنك لن تحتاج لها لان مافعله الاستاذ @ابوخليل سوف لن يجعل عدد الايام اكثر من 30 او عدد الاشهر اكثر من 12 واليك مافعله استاذنا للاستفادة : 1- في عمود rs تم حساب عدد الايام للخدمة الكلية 2- العمود rsw يظهر لنا باقي قسمة عدد الايام الكلي على 360 يوم والتي نحتاجها لاحقا 3- العمود rs_y يظهر لنا عدد سنوات ايام الخدمة الفعلية دون كسور مع الانتباه الى ان الاستاذ استخدم العلامة (\) وليس علامة القسمة (/) 4- العمود rs_d يظهر لنا المتبقي من قسمة عدد الايام الكلية مقسوما على 30 يوم 5- العمود rs_m يظهر لنا ناتج طرح الايام التي ظهرت في عمود الفقرة 2 امن الايام التي ظهرت في العمود 4 مقسوما على 30 لتظهر لنا عدد الاشهر 6- النتيجة ظهرت لنا عدد السنوات في rs_y وعدد الاشهر في rs_m وعدد الايام في rs_d

خالص الشكر والتقدير لك .. جزاك الله خير

ظبط تسلم حبيبي .. جزاك الله خيرا

بعض الناس تريد أن تتعلم وبعضهم للأسف يريد الحل جاهزا تم عمل المطلوب بالمرفق بالتوفيق ‏‏برنامج تقييم الزيارات عن بعد للوحدات مكرر - نسخة.xlsb

ينغي فك الدمج في جميع الخلابا المدمجة قبل استعمال الفرز أو الترتيب بعد فك الدمج في الأعمدة وتحديد أول صف قبل البيانات والضغط على زر التصفية filter في تبويب بيانات data (رمز القمع) سيتحقق المطلوب بإذن الله

جزيت خيرا .. مشكور

تفضل جمع مدد الخدمة بالنموذج2.rar

Sub Test() Dim a, ws As Worksheet, sh As Worksheet, r As Range, txt As String, i As Long Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) sh.Range("A3:C" & Rows.Count).ClearContents Set r = ws.Range("F2:M" & ws.Cells(Rows.Count, "F").End(xlUp).Row) a = r.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) If a(i, 8) = sh.Range("A1").Value Then txt = Join(Array(a(i, 2), a(i, 3)), Chr(2)) If Not .Exists(txt) Then .Item(txt) = .Count + 1 a(.Count, 1) = a(i, 2) a(.Count, 2) = a(i, 3) a(.Count, 3) = Evaluate("SUMIFS('" & ws.Name & "'!" & r.Columns(4).Address & ",'" & ws.Name & "'!" & r.Columns(1).Address & ","">=""&" & "'" & sh.Name & "'!" & Range("C1").Address & ", '" & ws.Name & "'!" & r.Columns(1).Address & ",""<="" &" & "'" & sh.Name & "'!" & Range("D1").Address & ",'" & ws.Name & "'!" & r.Columns(2).Address & "," & Chr(34) & a(.Count, 1) & Chr(34) & ",'" & ws.Name & "'!" & r.Columns(3).Address & "," & Chr(34) & a(.Count, 2) & Chr(34) & ")") End If End If Next i i = .Count End With sh.Range("A3").Resize(i, 3).Value = a End Sub

الحمدللة والشكرللة تمكنت بفضل الله من تصميم تقرير فى الاكسيس كما بالشكل فى اكسيل

انظر هنا <<<<<<<>>>>>>>>

جزيت خير هو المطلوب

السلام عليكم اساتذتي الاعزاء تسلم ايدك استاذنا العزيز @ابوخليل كلوا تمام بارك الله فيك لدي طلب اخر لو سمحت وهو عمل حساب الخدمة الوظيفية عن طريق الاستعلام لفد وجدت وحدة نمطية لاحد الاساتذة في الموقع يتم استدعائها عن طريق الاستعلام وعملت منها وحدة نمطية منها لجمع الايام والثانية لجمع الاشهر والثالثة لجمع السنوات والرابعة تشمل الكل باليوم والشهر والسنة لكن واجهتني اخطاء بعملية الجمع والطرح وظهور ارقام بالسالب يوجد ملف مرفق ارجو التعديل علية لاهمية الموضوع تحياتي للجميع ' الوحدة النمطية الاصلية Function Work(SumDto, SumMto As Byte, SumYto As Integer) As String Dim dd, mm As Byte Dim yy As Integer If SumDto > 30 Then SumDto = SumDto Mod 30 SumMto = SumMto + 1 End If If SumMto > 12 Then SumMto = SumMto Mod 12 SumYto = SumYto + 1 End If dd = SumDto mm = SumMto yy = SumYto Work = dd & " يوم و" & mm & " شهر و" & yy & " سنة" End Function جمع مدد الخدمة بالنموذج.accdb

إذا ساعدك أحدهم في تنفيذ كل هذا فماذا أبقيت لنفسك حتى تطبق ما تعلمته أخي الكريم ؟؟؟ إذا استخدمت البحث ستجد الكثير من الموضوعات التي تفيدك في تنفيذ برنامجك وهذه بعضها https://www.officena.net/ib/search/?q=فورم بحث تعديل حذف&type=forums_topic&nodes=135&updated_after=any&sortby=relevancy&search_and_or=and&search_in=titles عليك بالبدء في تنفيذ برنامجك وإذا وقفت في نقطة أو اثنتين يمكن عرضها في موضوع جديد بالتوفيق

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم تحياتي

وش اقول لك بس انت غير كانت المشكلة في عدد الاعمدة 2 وعمود منظم 2 ..... كانت 1 الف الف شكر ومليون باقة ورد ما تكفيك ..... الله يجزاك خير ويكتب اجرك ... شكر شكرا والشكر موصول للاستاذ @محمد ابو عبدالله

مبارك - نساله تعالى لكم التوفيق والتقدم ما شاء الله، أسأل الله أن يبارك لك وينفع بك أمة محمد صلى الله عليه وسلم

Sheet1 should be unprotected to let the code modify the quantity In the following code replace this word ÈíÚ with the Arabic equivalent This is worksheet module (Transaction worksheet) Private Sub Worksheet_Change(ByVal Target As Range) Dim x If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Row > 2 And Target.Column = 7 Then Application.EnableEvents = False x = Application.Match(Target.Offset(, -5).Value, Sheets(1).Columns(3), 0) If Not IsError(x) And Target.Offset(, -1).Value = "ÈíÚ" Then If MsgBox("New Stock Will Be Updated And This Row Will Be Delete. If OK Click 'Yes'", vbYesNo + vbQuestion) = vbYes Then Sheets(1).Cells(x, 5).Value = Sheets(1).Cells(x, 5).Value - Target.Value Target.EntireRow.Delete End If End If Application.EnableEvents = True End If End Sub

حياك اخي @عبد اللطيف سلوم بالتوفيق ........

وعليكم السلام .. سيتغير الاسم في النموذج والاستعلام .. اما اذا كنت تشير لاسم جدول في اكواد معينة بالتاكيد سيحصل خطأ

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

Mr. Mohamed's solution is simpler and better but this is my try using VBA in worksheet module Private Sub Worksheet_Change(ByVal Target As Range) Dim x, r If Target.CountLarge > 1 Then Exit Sub Application.EnableEvents = False With Sheets(2) If Target.Address = "$E$5" Then If IsEmpty(Target) Then Target.Offset(, 1).ClearContents x = Application.Match(Target.Offset(, -1), .Rows(1), 0) r = Application.Match(Target.Value, .Columns(x), 0) If Not IsError(x) And Not IsError(r) Then Target.Offset(, 1).Value = .Cells(r, x).Offset(, 1).Value End If End With Application.EnableEvents = True End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim x, c As Long, sList As String If Target.CountLarge > 1 Then Exit Sub Application.EnableEvents = False With Sheets(2) If Target.Address = "$D$5" Then For c = 1 To 53 Step 2 sList = sList & IIf(sList = Empty, Empty, ",") & .Cells(1, c).Value Next c With Target.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="" & sList End With Target.Offset(, 1).Resize(1, 2).ClearContents ElseIf Target.Address = "$E$5" Then If IsEmpty(Target.Offset(, -1)) Then Target = Empty Else If Target = Empty Then x = Application.Match(Target.Offset(, -1), .Rows(1), 0) If Not IsError(x) Then Target.Validation.Delete Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & .Name & "!" & .Range(.Cells(2, x), .Cells(.Cells(Rows.Count, x).End(xlUp).Row, x)).Address End If End If End If End If End With Application.EnableEvents = True End Sub

عليكم السلام و رحمة الله وبركاته إن شاء اللّه يكون هذا هو المطلوب تم استعمال أربعة أعمدة مساعدة في جلب البيانات حتى تعمل دوال البحث بدقة بالتوفيق اسعار الشحن.xlsx

وعليكم السلام ورحمة الله وبركاته يمكنك استخدام استعلام الحاق لتفيذ الجزء الاول DoCmd.SetWarnings False DoCmd.OpenQuery "Query1" DoCmd.SetWarnings True وللجزء الثاني استخدم الكود التالي Me.NO.SetFocus Me.NO = "" بيانات الموظفين.accdb تحياتي

بارك الله فيك حبيبنا ... وثناءك العاطر ....

تفضل هذا التعديل transport.accdb

To get the last row in specific column using formulas you can use these formulas =SUMPRODUCT((MAX(IFERROR(((A:A)<>""),TRUE)*ROW(A:A)))) =LOOKUP(2,1/(NOT(ISBLANK(A:A))),ROW(A:A)) To get the data in the last row in specific column, you can use this formula =LOOKUP(2,1/(B:B<>""),B:B) But if you seek to get the last row in any column in the active sheet, you have to use VBA instead Sub Test() Dim r As Range, m As Long Set r = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlValues) If Not r Is Nothing Then MsgBox "Last Row In The Active Worksheet: " & r.Row & vbCrLf & "The Last Row Is In Column: " & r.Column End If End Sub

عليكم السلام و رحمة الله وبركاته علي افتراض أن العمود المطلوب هو B يمكنك استعمال هذه المعادلة وهي أحد الحلول وليست الحل الوحيد =INDEX(B:B,COUNTA(B:B)) فجميع دوال البحث تجدي في هذه الحالة ويمكن سحب المعادلة أفقيا للتطبيق على أكثر من عمود بالتوفيق

استاذي ومعلمي @kanoryالمحترم اسمح لي بمداخلة .. لا اعتقد هذا مطلب صاحب المشاركة فالزبون ليس له علاقة بالموضوع وانما المخزن (رغم تحفظي على النموذج) الموضوع اشبه بنظام الفنادق .. صاحب الاوتيل ليس له علاقة بالزبون انما مجرد تسجيل بياناته .. المهم لديه اظهار الغرف المستأجرة عن غيرها فاذا اراد سهوا استئجار احدى الغرف لزبون وفي الاساس كانت مستأجرة فتظهر له رسالة تنبيه .. اعتذر على الاطالة

الجزء الخاص بالتاريخ على افتراض انه في العمود D الذي يلي C بمقدار عمود 1 هو F.Offset(0, 1) = ComboBox2.Text ولتغييره للعمود A الذي يسبق C بمقدار 2 F.Offset(0, -2) = ComboBox2.Text لذلك جرب الكود كاملا Set ws = Sheets("اصناف") For Each F In ws.Range("c5:c5000") If F = ComboBox1.Text and F.Offset(0, -2) = ComboBox2.Text Then ws.Select F.Select Exit For End If Next F ActiveCell.Value = ComboBox1.Value ActiveCell.Offset(0, 4).Value = TextBox4 ActiveCell.Offset(0, 5).Value = TextBox5 ActiveCell.Offset(0, 6).Value = TextBox6 ActiveCell.Offset(0, 9).Value = TextBox7 ActiveCell.Offset(0, 10).Value = TextBox8 MsgBox "تم تعديل البيانات بنجاح" End Sub وكان ينبغي أن تتوصل لها وحدك بالتوفيق

طيب انا اسف تقريبا انا ما قدرت افهم الموضوع جرب المرفق الاتى ان شاء الله يكون تمام ImportExcel 3.zip

لا كل مره بيتم حذف الجدول اولا DoCmd.DeleteObject acTable, strTable ثم الاستيراد من خلال الكود DoCmd.TransferText acImportDelim, , strTable, FSO.GetFileName(Me.txtFileName), True

أخي @ابا جودى ** الملف الذي ارفقه الأخ السائل مكون من عدة أعمدة . ** الأمر الآخر ماذا لو كان عنده أكثر من ملف هل يظل يغير اسم الجدول في كل مرة في الكود ؟؟

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

غير كما تشاء الملف والكود ملك يمينك هل تمت الاجابة على سؤالك على الوجه الذى تريده ؟!

اتفضل المرفق وجرب الاكسل تبعى انا اسم الملف : Template2.csv ImportExcel 2.zip

للعلم فى مشكلة فى ملفات الاكسل تبعك استبدل الكود على زر الامر الخاص بالإستيرد بالكود الاتى On Error GoTo Err_MyProc Dim strTable As String Dim FSO As New FileSystemObject If Nz(Me.txtFileName, "") = "" Then MsgBox "Please select a file!" Exit Sub End If If FSO.FileExists(Nz(Me.txtFileName, "")) Then strTable = "tblJudy" 'Table Name DoCmd.DeleteObject acTable, strTable DoCmd.TransferText acImportDelim, , strTable, FSO.GetFileName(Me.txtFileName), True MsgBox "Transfer Complete!" Else MsgBox "File not found!" End If Err_MyProc: 'Error handler here. Resume Next

ممكن مثال مصغر ...

ضع هذا الكود في وحدة نمطية: Public Sub SetFntName(strFName As TextBox) Rem: استبدل خط ايريل بالخط الذي تريد strFName.FontName = "Arial" End Sub يتم الاستدعاء هكذا: Call SetFntName(TxtName)

تظهر هذه الرسالة فى حالة كتابة إسم الملف المطلوب ضغطه وإصلاحه بطريقة خاطئة وإليك هذا الكود الذى يقوم بضغط وإصلاح قاعدة البيانات يوم الخميس من كل أسبوع وعمل نسخة منها فى موقع آخر على الهاردديسك يمكنك وضعه فى حدث زر إغلاق قاعدة البيانات ( طبعا بعد تعديل الإسم والمسار) 'If today = thrusday Then copy the data file Else go away If Weekday(Now()) <> 5 Then GoTo GoAway Dim MyDistenation As String MyDistenation = "E:\ArsheefData\" MyDistenation = MyDistenation + Format(Now, "dd-m-yyyy") MyDistenation = MyDistenation + ".mdb" DBEngine.CompactDatabase "E:\Data\ArsheefData\ArsheefData.mdb", MyDistenation GoAway: DoCmd.Close