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

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

وعليكم السلام والرحمة كود: Sub test() Dim a Dim x&, i&, c& Dim r As Range Dim firstaddress As String With Sheets("التقرير") a = .Range(.Cells(6, 1), .Cells(6, 3).End(xlDown)) x = .Cells(2, 6) End With With Sheets("كشف الطباعة") Set r = .Columns("a").Find("م", , , 1) If Not r Is Nothing Then firstaddress = r.Address Do [r].Offset(1).Resize(x, UBound(a, 2)) = Application.IfError(Application.Index(a, _ Evaluate("Row(" & c + 1 & ":" & x + c & ")"), [{1, 2,3}]), "") Set r = .Columns("a").FindNext(r) c = c + x Loop Until r.Address = firstaddress End If End With End Sub ترحيل الاسماء.xlsm

اثلجت صدري بردك

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

السلام عليكم اظن الأمر لا يحتاج الى كود للترحيل وممكن استعمال دالة Indirect مع دالة بسيطة لتعريف الصفحات معتمدة على الخلية F2 كما هي مكتوبة في الخانات F5 الى F14 كما في شيت "كشف الطباعة" بالملف المرفق وممكن تسهل على نفسك الأمور أكتر وتطبع الجدول بعد ما تضيف Page Header و Page Footer وتتحكم بارتفاع الاسطر لتحديد عدد الأسماء في كل صفحة كما بالشيت "كشف الطباعة 2" بنفس الملف , ترحيل الاسماء.xlsm

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

انضم لاخى ابو البشر بالنسبه لى قمت بالتجربه ويندوز 7 اوفيس 2019 الجميع 32 بت فظهر لى الخطأ رقم 3270 وبحثت بعدها فوجدت بانه لايجد الخاصيه لاضافتها فقمت باضافه الخواص Private Sub أمر0_Click() On Error GoTo Error_Handler Static acc As Access.Application Dim db As DAO.Database Dim strDbName As String strDbName = CurrentProject.Path & "\a.accdb" Set acc = New Access.Application Set db = acc.DBEngine.OpenDatabase(strDbName, False, False) acc.OpenCurrentDatabase strDbName Set Property = acc.CurrentDb.CreateProperty("StartUpForm", 10, "frm_2", True) Call acc.CurrentDb.Properties.Append(Property) ' acc.DoCmd.OpenForm "frm_2" Error_Handler_Exit: Exit Sub Error_Handler: If Err.Number = 3367 Then Resume Error_Handler_Exit End If db.Close Set db = Nothing End Sub New folder.rar

تفضل Sub All() ' ' All Macro ' Dim x as long for x =0 to 4 Sheets("Sheet2").Select Range("A2:B2").offset(x,0).Select Selection.Copy Sheets("Report").Select Range("K6").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Application.Run "'Egypt Report Tool_v14.xlsm'!ConnectSqlServer" Application.Run "'Egypt Report Tool_v14.xlsm'!SaveMyCover" ActiveWindow.Close next End sub =========== ملاحظة : تستطيع تغيير القيمة X الموجودة في بداية الكود وهي تعني عدد مرات التنفيذ كما في الكود أعلاه : إذا كانت X من صفر إلى 4 فهذا يعني أنك تريد تنفيذ الكود 5 مرات عند 0 أول مرة بداية من السطر رقم 2 يعني A2:B2 عند 1 ثاني مرة السطر 3 يعني A3:B3 عند 2 ثالث مرة السطر 4 يعني A4:B4 عند 3 رابع مرة السطر 5 يعني A5:B5 عند 4 خامس مرة السطر 6 يعني A6:B6 وهكذا ...

يمكن انني لم افهم عنك تفضل يجلب اخر ادخال test4.rar

ممكن هذا... =IF($E667="","",IF(OR(BZ667="غ",BZ667="معفى"),BZ667,SUM(AG667,BZ667)))

Private Sub UserForm_Initialize() Dim LastRow As Long Dim LastCol As Long Dim Criteria1 As String Dim Criteria2 As String Dim Result As String LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row LastCol = Sheet1.Cells(1, Sheet1.Columns.Count).End(xlToLeft).Column Criteria1 = Sheet1.Range("A2").Value Criteria2 = Sheet1.Range("B2").Value Result = Application.Vlookup(Criteria1 & Criteria2, Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(LastRow, LastCol)), 3, False) Me.TextBox1.Value = Result End Sub ممكن تجرب هذا الكود لعله يفيد وعدل عليه حسب الرغبه

تنسيق الخليه عندك معمول text اجعله general وسوف يعمل الكود تفضل invoice ss new (1).xlsm

الرابط اللي اعطيتك ، فيه الكود ، وتقدر تستفيد من عمل @محمد سلامة لأنه له باع قديم في الموضوع 🙂 راجع الرابط ، انت مو خسران 🙂 جعفر بالعكس ، الجو جميل وممتع 🙂

تفضل جرب الآن برنامج تنظيم الصور3 .rar

السلام عليكم مرفق حل بالمعادلات فقط (شرط ان لا تتكرر اسماء الدول فى السطر رقم 2) قوائم منسدلة ديناميكية.xlsx

نعم اخي @محمد احمد لطفى تحتاج الى مكتبة Microsoft Excel XX.X Object Library xx.x = رقم نسحة الاوفيس لديك 12.0 او 14.0 او 15.0 الخ.. تحياتي

وعليكم السلام ورحمه الله وبركاته 1- قم بتحميل برنامج Selenium من الرابط او من ميديا فاير ثم قم بتسطيبه كأي برنامج 2- تفتح الكروم علي هذه الصفحه chrome://settings/help لنعرف ما هو اصدار الكروم ولنفرض اننا وجدناه كما لدي Version 109.0.5414.120 (Official Build) (64-bit) نأخذ الرقم 109.0.5414.120 ثم نبحث في الصفحه علي هذا الرقم او ما يقرب له ثم نفتح الصفحه لدي كان اقرب رقم له هو https://chromedriver.storage.googleapis.com/index.html?path=109.0.5414.25/ ثم نقوم بتحميل الملف المسمي chromedriver_win32.zip بعد التحميل تقوم بفك الضغط عنه باي برنامج ضغط ثم تقوم بنسخه للمسار التالي %LOCALAPPDATA%\SeleniumBasic\ لو المسار دا مش موجود هتلاقيه في مجلد %ProgramFiles%\SeleniumBasic\ لو المسار دا مش موجود هتلاقيه في مجلد %ProgramFiles(x86)%\SeleniumBasic\ وتوافق على الاستبدال بندخل على محرر الأكواد عن طريق Alt + F11 .. من القائمة Tools نضغط على References ونضيف المكتبة الخاصة بالأداة Selenium بنعلم علامة صح على Selenium Type Library ونضغط أوك كما بالشكل التالي ثم ضع هذا الكود في ملفك في الفورم المسماه UserForm1 Private Sub CommandButton14_Click() Dim bot As New WebDriver, Keys As New Selenium.Keys Dim i As Long, WS As Worksheet Set WS = ThisWorkbook.Sheets("البيانات") With bot .AddArgument "kiosk-printing" .Start "chrome", "https://apps.moe.gov.jo/App/Clearance/" For i = 2 To WS.Cells(Rows.Count, "C").End(xlUp).row .Get "/" .Wait 1000 .FindElementById("txtNumber").SendKeys WS.Cells(i, "C") .FindElementById("btnSearch").Click .Wait 1000 .ExecuteScript "window.print()" Next i End With End Sub

وعليكم السلام تفضل المصنف1.xlsx

للفائدة هذي دالة Function وضيفتها تعيين الخواص لقاعدة البيانات .. وفي حال لو لقيها ما موجودة ينشأها 🙂 Public Enum propType PropTypeString = 1 PropTypeInteger = 2 PropTypeDouble = 3 PropTypeBoolean = 4 PropTypeDate = 5 End Enum Function CreateProperty(propName As String, propType As propType, propValue As Variant) ' Chat GPT On Error Resume Next Dim app As dao.Database Set app = CurrentDb app.CreateProperty propName, propType, propValue, True If Err.Number <> 0 Then ' Property already exists, set the value app.Properties(propName) = propValue End If On Error GoTo 0 End Function وتناديها بهذي الطريقة : Call CreateProperty("MyProperty", PropTypeString, "Hello World!")

ما شاء الله ، نماذج بتنسيق جميل ، بالفعل شيء يشرح الصدر 🙂 جعفر

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

تمام هذا حل المشكلة وهذا تمام شكرا لك

ياريت تخبرنا عنها ، لأنها ضاعت وسط الكود 🙂

1- ما ادري ، ما عملت اي تغيير في اي جزئية اخرى من الكود 😁 ولكن : لا تستعمل DoCmd.Close فهو يغلق اي كائن عليه التركيز ، سواء نموذج1 او نموذج2 او حتى التقارير وانما استعمل DoCmd.Close acForm, me.Name والذي معناه اغلاق النموذج الموجود فيه الكود هذا او DoCmd.Close acForm, "frm_relink" والذي يغلق النموذج الموجود اسمه في الكود 2- نعم ، هكذا If tdf.Name = "shet_Data" Then Call CurrentDb.TableDefs.Delete(tdf.Name) DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel12Xml, _ "shet_Data", CurrentProject.Path & "\Data.xlsx", True, "ورقة1" & "$" elseIf tdf.Name = "shet_Data2" Then Call CurrentDb.TableDefs.Delete(tdf.Name) DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel12Xml, _ "shet_Data2", CurrentProject.Path & "\Data.xlsx", True, "ورقة21" & "$" elseIf tdf.Name = "shet_Data3" Then Call CurrentDb.TableDefs.Delete(tdf.Name) DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel12Xml, _ "shet_Data3", CurrentProject.Path & "\Data3.xlsx", True, "ورقة1" & "$" Else

حياك الله اخي الدكتور محمد اليك ثلاثة ملفات باكواد مختلفة وجميعها تعمل بشكل صحيح مع الويندوز 10 والاوفيس 2019 . وكما ذكرت سابقا لن استطع التطبيق على الويندوز 7 والاوفس 2010 لانني لا املكهم. اتمنى من باقي الاعضاء والاساتذة ممن لديهم إمكانية تجربة الملف وإبداء الرأي حتى نستطيع حل المشكلة. وكنت أتمنى من الاخ @tamer.murad صاحب الموضوع ان يبدي رأيه أيضا. تحياتي لشخصكم الكريم 1275940712_AllVer.MediaSoft.rar

جاري التطبيق ... بارك الله فيكم

تفضل هل هذا ما تريد 0.accdb

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

تفضل اخي شوف التعديل هل هو المطلوب؟ Option Compare Database Option Explicit Dim strSQL As String Dim rs As DAO.Recordset Dim PreviousSearchText As String Private Sub CmdClear_Click() Me.TEXT_CHERCHE = "" Me.Query_no_subform.Form.Filter = "" Me.Query_no_subform.Form.FilterOn = False Me.Query_no_subform.Form.Requery End Sub '1 OK Private Sub TEXT_CHERCHE_Change() If Me.TEXT_CHERCHE.Text = "" Then Me.Query_no_subform.Form.Filter = "" Me.Query_no_subform.Form.FilterOn = False Else Dim strSQL As String strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34) Me.Query_no_subform.Form.Filter = strSQL Me.Query_no_subform.Form.FilterOn = True If Me.Query_no_subform.Form.Recordset.RecordCount = 0 Then MsgBox "لم يتم العثور على سجلات للنص المدخل", vbInformation, "تنبيه" End If End If End Sub Private Sub cmdPrintPreview_Click() Me.TEXT_CHERCHE.SetFocus strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34) ' Open the report in print preview mode DoCmd.OpenReport "MyReport", acViewPreview, , strSQL End Sub Private Sub TEXT_CHERCHE_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 27 Then Me.TEXT_CHERCHE.Text = "" Me.Query_no_subform.Form.Filter = "" Me.Query_no_subform.Form.FilterOn = False End If End Sub تحياتي my PR.accdb

السلام عليكم تفضل التعديل اتمنى ان يكون المطلوب 0.accdb

السلام عليكم كود لاحد الاساتذه بالموقع قمت بالتعديل عليه جربة واعلمنا النتيجة لان ليس لدي طابعة بالمنزل تحياتي Access.accdb

سأحاول الليلة إن شاء الله فإن وفقت في الحل رفعته لك. مع المعذرة .. حققت لك جزء من طلبك واسمح لي بالتوقف عند هذه النقطة موفقين. التكرار في اللجان_04.xlsm

وعليكم السلام 🙂 تفضل جعفر

نعم أخي الكريم تفضل Private Sub TreeView1_Click() Dim strFormName As String Dim formsDictionary As New Scripting.Dictionary formsDictionary.ADD "بيانات الشركة", "frmCompany" formsDictionary.ADD "بيانات مستخدمي النظام", "frmSystemUserData" formsDictionary.ADD "كلمات المرور", "frmPassword" formsDictionary.ADD "بيانات المطورين", "frmDeveloper" strFormName = TreeView1.SelectedItem.Text If formsDictionary.Exists(strFormName) Then DoCmd.OpenForm formsDictionary(strFormName) Else MsgBox "عذرا هذا النموذج غير موجود", vbExclamation, "تنبيه" End If End Sub واليك الملف بعد التعديل . المكتبات المطلوبة انظر الصورة بالتوفيق MediaSoft 2.rar

وعليكم السلام ورحمة الله وبركاته 🙂 سيدي الفاضل ، يجب الاشارة الى اسم النموذج الفرعي الذي به البيانات "email5" ، فيصبح كود الحقل "sub" : =" شهادة " & " الطالب / " & [email5]![toname] & " بالصف / " & [email5]![الصف] & " رقم الملف / " & [email5]![id] جعفر

اخي هل هناك ملف اخر غير الدي قمت بارفاقه في المشاركة تريد تنفيد الامر عليه بعد اضافة الكود قم بحفظ الملف بصيغة الماكرو

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Private Sub Worksheet_Activate() Set ws = Sheet1 StartRow = 7 'اول صف EndRow = 34 ' اخر صف ColNum = 2 'رقم عمود الشرط Application.ScreenUpdating = False 'بما انني لاحظت انك واضع حماية للشيت قمنا باضافة فك الحماية لتنفيد الكود ثم ارجاعها Sheet2.Unprotect ' في حالة قمت بالغاءها قم بالغاء تفعيل هدا السطر For i = StartRow To EndRow If ws.Cells(i, ColNum).Value = "" Then Cells(i, ColNum).EntireRow.Hidden = True Else Cells(i, ColNum).EntireRow.Hidden = False End If Next i Sheet2.Protect ' وهنا Application.ScreenUpdating = True End Sub بكج الافراد.xlsm

السلام عليكم ورحمه الله وبركاته وبها نبدأ اي موضوع يمكنك ذلك عن طريق كود vba كليك يمين على الصفحه (نسخة الزبون) والضغط على view code ثم نسخ هذا الكود ولصقه في حدث الشيت كما هو ولا تنسي يتم حفظ الملف بصيغه تقبل الماكرو xlsm او xlsb Private Sub Worksheet_Activate() Dim r As Range, i As Long Cells.EntireRow.Hidden = False For i = 7 To 34 If Cells(i, 2) = "" Then If r Is Nothing Then Set r = Cells(i, 2) Else Set r = Union(r, Cells(i, 2)) End If End If Next i If Not r Is Nothing Then r.EntireRow.Hidden = True End Sub

هذا خط كوفي .. وهذا أقرب مثال وجدته للخط المكتوب عندك 🙂 https://arbfonts.com/mcs-shafa-e-u-normal-font-download.html?preview=صورة+قيد+مقفل واطلع على هذه أيضا : https://arbfonts.com/mcs-shafa-s-u-normal-font-download.html https://arbfonts.com/alawi-shafa-font-download.html https://arbfonts.com/mcs-shafa-e-i-normal-font-download.html التحميل من نفس الصفحات 🙂

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

تعني رقم المفتاح او الزر في لوحة المفاتيح تجد هنا ارقام المفاتيح http://www.officena.net/ib/index.php?showtopic=48801#entry295956

If KeyCode = 13 Then DoCmd.GoToRecord , , acNewRec End If تم تطبيق الكود على الحقل n يمكنك نقله الى اي حقل تريد 1.rar

ارجوك ارجوك اخوي ابوخليل ، خليني استمتع بهذه اللحظة ، استراحة المحارب 🙂

وعليكم السلام ورحمة الله وبركاته 🙂 الظاهر اني مال ضرابه اليوم ، كل موضوع واكون مكشر فيه 😁 . قوانين المنتدى تقول: 13. - يمنع وضع السؤال داخل المرفق، يجب شرح السؤال بالتفصيل لتعم الفائدة، ولا مانع من اضافة صورة توضيحية هذا الموضوع مشابه لطلبك جعفر