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

وهذه مساهمة مني: Dim crl As Control On Error Resume Next For Each crl In Me.Controls With crl If Not Right(.Name, 2) Like "1[1-5]" Then .Value = Null End If End With Next crl

السلام عليكم قبل البدء انت محتاج تغير ال listbox اللى قدام الكود الى combobox وليكن combobox2 اولا انت محتاج تملا الكمبو بوكس مع بداية عمل الفورم Private Sub UserForm_Initialize() Dim LR As Long With Sheets("update 2022 September") LR = .Range("A" & .Rows.Count).End(xlUp).Row Me.ComboBox2.RowSource = "=$A$4:$A$" & LR Me.ComboBox1.RowSource = "=$C$4:$C$" & LR End With End Sub كده انت ملأت الاتنين الكمبوبوكس يبقى انت محتاج كود عند تغيير الكمبوبوكس Private Sub ComboBox2_Change() ComboBox1.ListIndex = ComboBox2.ListIndex If ComboBox2.ListIndex <> -1 Then TextBox3.ControlSource = "=$H$" & ComboBox2.ListIndex + 4 Else TextBox3.ControlSource = "" TextBox3.Text = "" End If End Sub وبكده التكست بوكس اصبحت مرتبطه بالخليه يعنى اي تغيير فيها ها يتحدث اتوماتيتك فى الخليه * الجمله الشرطية للتأكد انك كتبت كود موجود داخل الليست , , والا يلغى ارتباط التكست بوكس بالخلية ثم يمسح محتوى التكست بوكس * ال 4 دي بداية اول سطر بيانات فى الجدول

وعليكم السلام 🙂 اجعل اسم الزر cmd_clear_fields ، ثم ضع الكود في حدث النقر على الزر: Private Sub cmd_clear_fields_Click() On Error GoTo err_cmd_clear_fields_Click Dim ctl As Control For Each ctl In Me.Controls If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then If ctl.Name <> "g1s11" And _ ctl.Name <> "g1s12" And _ ctl.Name <> "g1s13" And _ ctl.Name <> "g1s14" And _ ctl.Name <> "g1s15" Then ctl.Value = "" End If End If Next Exit_cmd_clear_fields_Click: Exit Sub err_cmd_clear_fields_Click: If Err.Number = 2448 Then 'can't change autonumber Resume Next ElseIf Err.Number = 3314 And ctl.Name = "g1s3" Then 'a date must be entered ctl.Value = Date Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If Resume Exit_cmd_clear_fields_Click End Sub جعفر up.zip

تفضل التعديل أخي m.r 🙂 Sub CopyFile() Dim sPathDeskTop As String sPathDeskTop = Environ("USERPROFILE") & "\Desktop" & "\b\" ' هنا اسم المجلد الذي سيتم انشاؤه في سطح المكتب Dim CopyFrom As String, CopyTo As String CopyFrom = Me.SourceFilePath ' هنا تضع اسم الحقل الذي به رابط الملف المراد نسخه CopyTo = sPathDeskTop & Me.NewFileName & ".pdf" ' هنا تضع اسم الحقل الذي به اسم الملف الجديد وامتداده If Len(Dir(sPathDeskTop, vbDirectory)) = 0 Then MkDir (sPathDeskTop) If Len(Dir(CopyTo, vbDirectory)) = 0 Then FileCopy CopyFrom, CopyTo Else MsgBox "هذا الملف موجود مسبقا", vbOKOnly Exit Sub End If End Sub

طبعا أنا كنت أجرب قبل ما أشوف مشاركة أستاذنا العزيز جعفر 🙂 وهذي محاولتي : طبعا يتم استعراض ملفات ال PDF في المتصفح ( وهذا يتطلب وجود برنامج مشغل PDF ) ويمكن الاستغناء عن العرض الكود يجلب كل الملفات المرتبطة بالرقم المطلوب تلقائيا عند الإنتقال من سجل لآخر في النموذج الفرعي ويجمعها في ليست بوكس .. النقر المزدوج على اسم الملف يفتحه لك خارجيا .. وهذا الكود : Public Sub BringAllFilesAndFolders() Dim path As String, currentPath As String Dim List As ListBox Set List = Forms!tabl1!FileList path = CurrentProject.path & "\Datapdfx\" currentPath = Dir(path, vbDirectory) List.RowSource = "" Do Until currentPath = vbNullString If InStr(currentPath, CStr(Me.noid)) > 0 Then List.AddItem currentPath End If currentPath = Dir() Loop Set List = Nothing End Sub ربط البيانات مع ملف pdf.rar

وعليكم السلام 🙂 تفضل: . وهذا يحدث بهذا الكود: Private Sub Form_Current() Dim rst As DAO.Recordset Dim strFile As String Set rst = Me.tabl2.Form.RecordsetClone rst.MoveFirst Me.lst_Files.RowSource = "" Do Until rst.EOF Debug.Print rst!noid Me.lst_Files.AddItem ">" & rst!noid 'Now lets find how many files we have strFile = Dir(Application.CurrentProject.Path & "\Datapdfx\*" & rst!noid & "*.pdf") Do Until strFile = "" Debug.Print strFile Me.lst_Files.AddItem strFile strFile = Dir() Loop Me.lst_Files.AddItem "" rst.MoveNext Loop End Sub Private Sub lst_Files_DblClick(Cancel As Integer) Dim pdfPath As String If Left(Me.lst_Files, 1) = ">" Then Exit Sub pdfPath = CurrentProject.Path & "\Datapdfx\" & Me.lst_Files Shell "explorer.exe " & pdfPath, vbNormalFocus End Sub جعفر dataPdf.zip

حياك الله أستاذ جعفر ، تحسين في الكود: Dim crl As Control On Error Resume Next For Each crl In Me.Controls With crl If Not Right(.Name, 2) Like "1[1-5]" Then Err.Clear .Value = "" If Err.Number <> 0 Then .Value = Date 'لا أنصح بهذا السطر End If End With Next crl

هههههه لتنفيذ هذه الفكرة ممكن استخدام الامر التالي في زر امر If Me.NewRecord Then Exit Sub Dim x As Variant Dim a As Variant x = ([g1s11] & "|" & [g1s12] & "|" & [g1s13] & "|" & [g1s14] & "|" & [g1s15]) DoCmd.GoToRecord , , acNewRec a = Split(x, "|") [g1s11] = a(0) [g1s12] = a(1) [g1s13] = a(2) [g1s14] = a(3) [g1s15] = a(4) وممكن بدون الحاجة الى مصفوفة عن طريق حلقة مشابهه لكود استاذنا جعفر تحياتي

السلام عليكم 🙂 اخي ابو احمد @AbuuAhmed اسمح لي اكون اول من يُهنّيك على الترقية 🙂 هي مجرد القاب للمحترفين ، وتعريف الباقين بكم 🙂 جعفر

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

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

وعليكم السلام ورحمة الله وبركاته ...... راجع مصدر تصدير البيانات الى الاكسل وتأكد من ان بيانات النموذج الفرعي ظاهرة فيها ..... او ارفق مثال مصغر لماتريد فعله ز

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

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

الحمد لله،، ثم الحمد لله.. المبدعون الكرام.. @jjafferr @Moosak تقف الكلمات حائرة.. أمام جميل تعاونكم البناء وأخوتكم الكريمة.. تلاقت الأرواح بكل جمال ومحبة وصدق وتعاون.. فلكم منا صادق الدعاء فلقد أجدتم ونفعتم وكفيتم ووفيتم.. والحمد لله ضبطت الطريقة.. فشكر الله شكرا عظيما وجزاكم خير الجزاء وبارك لكم فيما رزقكم وجعل ما جدتم به رفعة لكم في الدنيا والآخرة..

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

السنة الهجرية = (السنة الميلادية-622)/0.97 +1 622 هي السنة الميلادية لبداية التقويم الهجري 0.97 هي نسبة طول السنة الهجرية إلى طول السنة الميلادية 354.3667 / 365.2425 = 0.970223071 1 هو للزيادة سنة لما يسمى بالسنة الناقصة/غير المكتملة

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

اخي لا اعلم الغرض من الفكرة لاكن اظن انه من الانسب لصق جميع القيم مباشرة وحدفها بعد الانتهاء من العد ادا لزم الامر اليك بديل ربما يناسبك نسخ جميع القيم من شيت البيانات الى شين فاتورة مع كود لتصفح القيم المحصل عليها واستخراج عددها . Sub cal() Dim MH& With Worksheets("البيانات") Range("A3:A50").ClearContents Range("B2").ClearContents MH = .Cells(.Rows.Count, "A").End(xlUp).Row - 1 Worksheets("فاتورة").Range("A1").Resize(MH).Value = .Columns(1).Resize(MH).Value Application.Goto Worksheets("فاتورة").Range("A2") End With For MH = 1 To MH With Worksheets("فاتورة") Range("b2").Value = MH End With Next MH End Sub Private Sub worksheet_selectionchange(ByVal target As Range) Dim r As Range With Me Application.Calculation = xlManual MH = .Cells(.Rows.Count, 1).End(xlUp).Row Set r = Intersect(target, .Columns(1).Resize(MH)) If Not r Is Nothing Then If r.Cells.Count = 1 Then PrevColor = r.Interior.Color r.Interior.Color = vbGreen Application.Wait Now + TimeValue("00:00:01") r.Interior.Color = PrevColor r.Offset(1).Activate Application.ScreenUpdating = False ActiveWindow.ScrollRow = 1 Range("A2:A50").ClearContents Application.Calculation = xlAutomatic Application.ScreenUpdating = True End If End If End With End Sub كود عداد الارقام.xlsm

السلام عليكم ,,,بعد تقديم كل الشكر والتحية لاعضاء الجروب المحترمين اقدم لكم ملف لعمل عروض الاسعار والفواتير ..الملف يعتبر تجميع موضوعات مختلفة في ملف واحد مميزات الملف ..الترحيل ...البحث ..التعديل حفظ نسخة من الملف Pdf .. الي الاميل Pdf ارسال ملف ال ارسال رينج معين كا صورة الي برنامج واتس اب الملف يعمل علي اوفيس 64 .. * InternetExplorer* يعتمد علي برنامج واتس اب ديسك توب او برنامج عرض سعر .xlsm

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

اهلا وسهلا بك مرة اخرى

الموضوع بسيط والاستاذ جعفر عمل حلقة في حقول النموذج تمر على الحقول وتستثني ما لا ترغب في تحديثة وايضا ممكن عملها باستعلام تحديث لكن السؤال هذه الحقول التي حدثتها الى فارغ لن تستطيع الرجوع اليها ؟ فلماذا لا تقوم بدلا من التحديث بنقل البيانات المستناه الى سجل جديد وبالتالي يكون لديك بيانات متكاملة حاليه وسابقة لكل سيارة ويمكن الرجوع عند الحاجة وجهة نظر غير ملزمة واشبه ماتكون بالتفكير بصوت مرتفع استاذي العزيز @jjafferr خالفت اتفاقي معك فالطبع يغلب التطبع

الف مبروك الترقية المستحقة

صراحة لم أستوعب الطلب جيدا ...جرب أخي Sub cal_MH() Dim LastRow As Long Dim i As Long, j As Long Application.Calculation = xlManual With Worksheets("البيانات") LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row - 1 End With For i = 1 To LastRow With Worksheets("فاتورة") Application.Wait (Now + TimeValue("00:00:01")) Range("A2").Value = i End With Next i Application.Calculation = xlAutomatic End Sub كود يقوم بقراءة الارقام عدها أي تسلسل الارقام.xlsm

الف مبروك 🌺

السلام عليكم ورحمة الله استخدم المعادلة التالية =OFFSET(البيانات!$A$2;COUNT(البيانات!$A:$A)-1;0)

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

اذا هذه حسبتك الدائمة فالناتج ثابت ويساوي = 14400 .. نقسم عليه الراتب ليخرج استحقاق الدقيقة الواحدة ثم نضرب استحقاق الدقيقة في عدد دقائق التأخر .. اذا ساعات العمل تختلف من موظف لآخر ..... وايضا ايام العمل في الشهر تختلف فيجب اتباع طريقة اخرى في التنفيذ ايضا وقت بداية العمل ليست ثابتة على مدار العام فيوجد توقيت شتوي وآخر صيفي ، هنا يلزمنا عمل جدول نضع فيه بداية الدخول ونهاية الخروج كتبت هذا على عجالة لم اطلع على المرفق سأوافيك بالتعديل على المرفق لاحقا بعد ان تعقب على رأيي اعلاه

تمام هو دة المطلوب والف الف شكر

موضوع دسم ما شاء الله تبارك الرحمن 🙂

اخي حامل المسك ، شكرا جزيلا على هذا الاطراء الجميل ، ولك مثل ما دعوت لي ، ومن اهمك امرهم 🙂 جعفر

السلام عليكم و رحمة الله اتمنى ان يكون هذا ما تصبو اليه Sub try01() Dim r, r2, x, l As Long Dim ws As Worksheet ' [هذه العبارة تم اضافتها حتى يعمل معك الكود من اى ورقة Set ws = Sheets("summare ") ' اسم الورقة التى سوف يتم العمل عليها ws.Range("b7:o1000") = "" ' محو البيانات القديمة x = ThisWorkbook.Sheets.Count ' عدد الشيتات فى الملف r = 7 ' الصف الذى سوف يبدأالعمل من خلاله For i = 3 To x ' ترتيب الشيتات التى سوف يتم استيراد البيانات منها 'اسم الشيت ws.Cells(r, "b") = Sheets(i).Name ' اسماء الشيتات تسجل فى هذا العمود ws.Cells(r, "c") = Sheets(i).Range("c8") ' رقم العقد و الموجود فى هذه الخلية من الشيتات المشار اليها ' عدد الصفوف بالشيت Z = Sheets(i).Cells(Rows.Count, "b").End(xlUp).Row ' آخر صف فى هذا العمود For i2 = 12 To Z ' البداية من الصف 12 حتى الصف 'التاريخ dt = Sheets(i).Cells(i2, "b") ' الاعمدة التى تحتوى على التواريخ التى سيتم جلب البيانات منها For i3 = 4 To 15 ' الاعمدة التى سوف يتم جلب البيانات اليها If Month(ws.Cells(6, i3)) = Month(dt) And Year(ws.Cells(6, i3)) = Year(dt) Then ' شرط استدعاء البيانات ws.Cells(r, i3) = Sheets(i).Cells(i2, "f") + ws.Cells(r, i3) ' الامر بأضافة البيانات End If Next i3 Next i2 r = r + 1 Next i End Sub

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