بحث مخصص من جوجل فى أوفيسنا
![]()
Custom Search
|
نجوم المشاركات
Popular Content
Showing content with the highest reputation on 10/25/20 in all areas
-
3 points
-
3 points
-
شغل النموذج Kanory ولاحظ الاستعلام الناتج -------->>>>>> 2132172302_FMARK_Kanory.mdb3 points
-
3 points
-
3 points
-
2 points
-
2 points
-
.هذه طريقة اخرى بدون كتابة اسماء الحقول وخاصة عندما تكون كثيرة ولكن بشرط ان تتشابه ترتيب الحقول في الجدولين Dim db As DAO.Database Dim rstFrom As Recordset Dim rstTo As Recordset Set db = CurrentDb Dim RC, i, r As Integer Set rstTo = db.OpenRecordset("tblB1", dbOpenDynaset) Set rstFrom = db.OpenRecordset("tblB", dbOpenDynaset) rstFrom.MoveFirst: rstFrom.MoveLast RC = rstFrom.RecordCount rstFrom.MoveFirst For i = 1 To RC rstTo.AddNew For r = 1 To rstFrom.Fields.Count - 1 rstTo.Fields(r) = rstFrom.Fields(r) Next r rstTo.Update rstFrom.MoveNext Next i rstTo.Close rstFrom.Close Set rstTo = Nothing Set rstFrom = Nothing Set db = Nothing Kan_355.accdb2 points
-
الكود يضيف كل السجلات الموجود في الجدول وذلك عن طريق الكود التالي RC = rstFrom.RecordCount rstFrom.MoveFirst For i = 1 To RC هذا الكود الذي انت وضعت جزءا منه لا يضيف كل الحقول الا اذا كتبت وحددت له الحقول بالشكل التالي rs.AddNew السطر التالي يعبر عن الحقل ..... قم بتكرار السطر بعدد الحقول الموجودة لديك rstTo!codhesab = rstFrom!codhesab rstTo!الحقل الثاني = rstFrom!الحقل الثاني وهكذا rs.Update أرفق لنا الجدولين وبه بيانات تجريبية للتطبيق2 points
-
تفضل .... Dim db As DAO.Database Dim rstFrom As Recordset Dim rstTo As Recordset Set db = CurrentDb Dim RC, i As Integer Set rstTo = db.OpenRecordset("table2", dbOpenDynaset) Set rstFrom = db.OpenRecordset("table1", dbOpenDynaset) RC = rstFrom.RecordCount rstFrom.MoveFirst For i = 1 To RC rs.AddNew rstTo!codhesab = rstFrom!codhesab rs.Update rstFrom.MoveNext Next i rstTo.Close rstFrom.Close Set rstTo = Nothing Set rstFrom = Nothing Set db = Nothing2 points
-
وعليكم السلام-لا يمكن عمل ما تريد ولكن يمكن كما تعلم مشاركة ملف الإكسيل لأكثر من شخص شرح مشاركة جدول اكسل للتعديل مع أكثر من شخص عن بعد Excel| انترنت أو شبكة داخلية1 point
-
سنه واشهر وايام ام فقط اشهر وايام هل في النموذج أم تقرير ....... ؟؟؟؟؟ على كل حال جرب الوحدة النمطية هذه unction CalcAge(vDate1 As Date, vdate2 As Date) Dim vYears As Integer, vMonths As Integer, vDays As Integer vMonths = DateDiff("m", vDate1, vdate2) vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2) If vDays < 0 Then vMonths = vMonths - 1 vDays = DateDiff("d", DateAdd("m", vMonths, vDate1), vdate2) End If vYears = vMonths \ 12 vMonths = vMonths Mod 12 CalcAge = vYears & "سنة, " & vMonths & "شهر, " & vDays & "يوم" End Functio استدعيها من خلال مربع النص هكذا Me.txtage.Text = CalcAge(Me.txtfrom, Me.txtto)1 point
-
مشاركة مع أبي عارف .. عملت لك تنسيق شرطي بلون مغاير للرقم صفر .. test.accdb1 point
-
1 point
-
الله عليك استاذنا الكبير(سليم) الف مليون تحيه وتقدير لحضرتك تم عمل كل المطلوب وبكفاءة عالية .... بفضل مجهودات حضرتك الحمدلله رب العالمين1 point
-
1 point
-
هذا الأمر سيكون متروكاً للباحث، حيث يقوم بإنشاء الموضوع الذي يريده، وضمنه يضع أسماء الكتب التي يريدها، بنفس فكرة الاستبدال المتعدد، حيث هنالك يمكن إنشاء أي مجموعة، وضمنها توضع العبارات. شكراً لك أخي العزيز 🙂1 point
-
تمام، ومن المهم أن يكون هناك ترتيب حسب الموضوعات، يعني مثلا: التفسير وعلومه، كتب الحديث، كتب الفقه، كتب اللغة، كتب الأدب، المعاجم، كتب النحو والصرف والعروض، ... إلخ. وبالتوفيق دائما.1 point
-
أكرمك الله أخي العزيز أبو عاصم. أنا لا أقصد ما تم تنفيذه من تحديثات جديدة على الإضافة، وإنما أقصد ما يتعلق باقتراح فهرس المصادر والمراجع، فهل ما ذكرته أنا هنا يلبي ما يتعلق بفهرس المصادر والمراجع؟1 point
-
حبيبنا الأستاذ شحادة، أنا الآن أعمل على جهاز ليس عليه الإضافة، وإن شاء الله عندما أعود إلى البيت أثبت الإصدار الجديد على جهازي الخاص، ثم أتابع معك. تحياتي لشخصكم الكريم.1 point
-
ما شاء الله، تمام، وسوف أذكر لك تباعا المشاكل التي يقابلها الباحث أثناء عمله في الكتاب، بداية من كونه مخطوطا، حتى تحويله إلى بي دي إف، مع المراجعات الفنية المطلوبة، مثل (الترويسة، والترقيم، والتصاق التشكيل) وغير ذلك. حتى تكون الإضافة شاملة لكل شيء إن شاء الله. * يعني مثلا: = كيف أرقم كتابا كاملا بصورة كاملة: (ترقيم الكتب، والأبواب، والأحاديث) مثلا. = كيف أميز الكتب عن الأبواب عن الأحاديث برمز معين حتى يتم الترقيم عليه. * إذا كان التشكيل فيه مخاطرة، فإن اختبار النص - مشكولا وغير مشكول- أمر ميسور، يمكن أن نوقف الباحث على مواضع الإشكال للنظر فيها. * وهناك أشياء كثيرة من هذا القبيل، يسعدني كثيرا أن أذكرها لك، من باب نشر الفائدة. شكر الله لك صنيعك، وجعله في ميزان حسناتك.1 point
-
استخدم الحماية ... بحيث لا يعمل البرنامج سوى الاجهزة التى تريدها فقط1 point
-
ربنا يبارك فيك استاذنا الفاضل ويبارك فى علمك ويجعله فى ميزان حسناتك ومعلش أنا أثقلت على حضرتك1 point
-
السلام عليكم ورحمة الله وبركاته الأخ الحبيب أبو عاصم، حياك الله، وبعد: أولاً: تم تنفيذ اقتراحك بإضافة ميزة (استيراد - تصدير) إلى نافذة الاستبدال المتعدد، وتم نشر التحديث الجديد 3.9.0.0. [الجديد في التحديث 3.90]: في نافذة استبدال متعدد، تم إضافة خاصيتين جديدتين: 1- تصدير: يمكنك من خلال هذه الخاصية تصدير عبارات مجموعة ما إلى مستند نصي. 2- استيراد: هذه الخاصية عكس الخاصية السابقة، حيث تسمح لك باستيراد عبارات من ملف نصي إلى المجموعة المختارة، مع الانتباه إلى أن العبارات المكررة سيتم استثناؤها من عملية الاستيراد، وضمن الملف النصي تكتب العبارة الخاطئة والصحيحة ضمن سطر بهذا التنسيق: العبارة الخاطئة[=]العبارة الصحيحة، وهو نفس التنسيق الذي يتم من خلال الخاصية السابقة. التحميل: https://www.shhada.net/contents/downloadsm/4MAEgubYzqynkm6y.zip ثانياً: أنت محق بخصوص ما ذكرته عن (فهرس المصادر والمراجع). بالحقيقة أفكر بإضافة هذه الخاصية بشكل احترافي، يلبي كافة الخيارات التي يريدها الباحث أو التي تعتمدها الجامعات. تصوري للموضوع على النحو الآتي: 1- تبويب الإضافة والتحرير: اسم الكتاب، اسم المؤلف، لقب المؤلف، المحقق، دار النشر، بلد النشر، رقم الطبعة، تاريخ الطبعة. مثلاً: الإتقان في علوم القرآن، جلال الدين عبد الرحمن بن أبي بكر، السيوطي، تحقيق: محمد أبو الفضل إبراهيم، مطبعة البابي الحلبي - مصر، الطبعة الرابعة، 1398هـ/1978م. هنا يتمكن الباحث من إدخال المعلومات للبرنامج بالإمكانات التالية: إضافة - تعديل - حذف - تصدير إلى ملف نصي - استيراد من ملف نصي وسيمكنه إضافة بيانات الكتب ضمن مجموعات يقوم بإنشائها؛ مثلاً: المعاجم اللغوية - الفقه الحنفي - التفسير، إلخ. نفس فكرة الإضافة في الاستبدال المتعدد. 2- تبويب إدراج فهرس المصادر والمراجع: يمكنه اختيار مجموعة كتب معينة لتظهر الكتب المرتبطة بها مع معلوماتها كاملة، أو يمكنه اختيار( كل) لتظهر له كل الكتب دون اعتبار مجموعة معينة. قائمة الكتب ستكون قابلة لتحديد كتب معينة من هذه القائمة. بالأسفل خيارات لتحديد طريقة الترتيب في فهرس المراجع؛ مثلاً الترتيب حسب التالي: - اسم الكتاب، اسم المؤلف ولقبه، المحقق، دار النشر، بلد النشر، رقم الطبعة، تاريخ الطبعة. - لقب المؤلف، اسم المؤلف، اسم الكتاب، المحقق، دار النشر، بلد النشر، رقم الطبعة، تاريخ الطبعة. - اسم الؤلف، لقب المؤلف، اسم الكتاب، المحقق، دار النشر، بلد النشر، رقم الطبعة، تاريخ الطبعة. وهكذا... بمجرد نقر زر إدراج، يتم إدراج الكتب المحدد مع بياناتها حسب طريقة الترتيب المختارة. ما رأيك بهذا، وهل لك تعقيبات أو توجيهات أو اقتراحات؟ أرجو الإفادة في هذا الموضوع.1 point
-
أعلم ذلك، لكن وجود مثل هذه القائمة بصورة سليمة يتيح للباحث النسخ منها مباشرة، أو استبدال البيانات، مع كتابتها بصورة صحيحة، لأنه من الملحوظات على قائمة المراجع أن الباحث كثيرا ما لا يلتزم بصورة واحدة لكتابة بيانات المرجع، من اسمه، واسم مؤلفه، ودار النشر، وسنة الطبع، وغير ذلك. ففي رأيي أن وجودها هنا ستكون إضافة مفيدة لإضافة البيان. الباحث يدرك أن هناك طبعات للكتاب، علما بأن تعدد الطبعات ليس هو الغالب، بل الغالب وجود طبعة واحدة، خصوصا في المصادر الكبيرة. وأقل ما يمكن أن يستفيد منه كتابة المصدر، مع اسم مؤلفه، بصورة سليمة. تحياتي لك، وصبحك الله بالخير.1 point
-
هذا أمر طبيعى ومنطقى بأن يطلب كلمة المرور عند فتح الملف كل مرة .... فلا يمكن عمل الإستثناء الذى تريده الا عند الغاء كلمة المرور نهائياً , وشكراً1 point
-
1 point
-
عندي اقتراح لإضافة قائمة مراجع للإضافة، بحيث يستفيد منها الباحث، بحيث تعرض على الباحث، فيختارها كلها، أو يختار منها ما اعتمد عليه في تحقيقه، وذلك عن طريق تحديد قائمة المراجع الخاصة به، ثم مقابلتها على قائمة البرنامج، فنستفيد الدقائمة مصادر التحقيق.rarقة مع السرعة:1 point
-
جرب هذا الماكرو تم تعديل القوائم المنسدلة في الشيت fasl و الشيت fasl2 النطاق "K1" ليتناسب مع كل الاحنمالات في الشيت main الزر All In One1 يعمل الفلترة وينقلها الى كل شيت بمفردها في الشيت fasl و الشيت fasl2 الزر استدعاء يتفذ الماكرو الخاص بكل منهما (مع الترقيم اوتوماتيكي بدون معادلات لتصغير حجم الملف من جهة و من جهة احرى لعدم العبث بالمعادلات اذا وجدت عن طربق الحطأ ) Option Explicit Private M As Worksheet Private F1 As Worksheet Private F2 As Worksheet Private LM%, LF1%, LF2% Private M_rg As Range, F1_rg As Range Private F2_rg As Range Private Filter_range As Range Private Cret1$, Cret2$ Private cont Private y% '++++++++++++++++++++++++++++++ Sub Get_all() My_filter_forF1 My_filter_forF2 End Sub Sub My_filter_forF1() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With First_Macro On Error Resume Next F1.Range("A6:J30").ClearContents Set Filter_range = F1.Range("k1") If M.AutoFilterMode Then M.Range("A3").AutoFilter M_rg.AutoFilter 5, Filter_range M_rg.AutoFilter 7, Cret1 M.Range("B4:B" & LM).SpecialCells(12).Copy F1.Range("B6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F1.Range("C6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F1.Range("D6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F1.Range("E6").PasteSpecial (12) cont = Application.CountA(F1.Range("B6:B25")) If cont > 0 Then F1.Range("A6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If M_rg.AutoFilter 7, Cret2 M.Range("B4:B" & LM).SpecialCells(12).Copy F1.Range("G6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F1.Range("H6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F1.Range("I6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F1.Range("J6").PasteSpecial (12) cont = Application.CountA(F1.Range("G6:G25")) If cont > 0 Then F1.Range("F6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If If M.AutoFilterMode Then M.Range("A3").AutoFilter On Error GoTo 0 With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub '+++++++++++++++++++++++++++++++++++++ Sub My_filter_forF2() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With First_Macro On Error Resume Next F2.Range("A6:J30").ClearContents Set Filter_range = F2.Range("k1") If M.AutoFilterMode Then M.Range("A3").AutoFilter M_rg.AutoFilter 5, Filter_range M_rg.AutoFilter 7, Cret1 M.Range("B4:B" & LM).SpecialCells(12).Copy F2.Range("B6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F2.Range("C6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F2.Range("D6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F2.Range("E6").PasteSpecial (12) cont = Application.CountA(F2.Range("B6:B25")) If cont > 0 Then F2.Range("A6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If M_rg.AutoFilter 7, Cret2 M.Range("B4:B" & LM).SpecialCells(12).Copy F2.Range("G6").PasteSpecial (12) M.Range("G4:G" & LM).SpecialCells(12).Copy F2.Range("H6").PasteSpecial (12) M.Range("H4:H" & LM).SpecialCells(12).Copy F2.Range("I6").PasteSpecial (12) M.Range("I4:I" & LM).SpecialCells(12).Copy F2.Range("J6").PasteSpecial (12) cont = Application.CountA(F2.Range("G6:G25")) If cont > 0 Then F2.Range("F6").Resize(cont) = _ Evaluate("ROW(1:" & cont & ")") End If If M.AutoFilterMode Then M.Range("A3").AutoFilter On Error GoTo 0 With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub ''++++++++++++++++++++++++++++++ Sub First_Macro() Set M = Sheets("main") Set F1 = Sheets("fasl") Set F2 = Sheets("fasl2") LM = M.Cells(Rows.Count, 2).End(3).Row LF1 = F1.Cells(Rows.Count, 1).End(3).Row If LF1 < 6 Then LF1 = 6 LF2 = F2.Cells(Rows.Count, 1).End(3).Row If LF2 < 6 Then LF2 = 6 Set M_rg = M.Range("A3:I" & LM) Set F1_rg = F1.Range("A6:J30") Set F2_rg = F2.Range("A6:J30") Cret1 = "ذكر": Cret2 = "أنثى" End Sub الملف مرفق Abou_malak.xlsm1 point
-
اتفضل لعله يفى بالغرض فى شيت fasl2 عند الاختيار من القائمة المنسدلة الفصل يجلب لك اسماء الطلاب ولغيت لك زر استدعاء الطلاب Copy of قوائم.xlsm1 point
-
1 point
-
1 point
-
Try This Macro Option Explicit Sub Colorize_Comments() Const CLR = 35 With Range("A1").CurrentRegion .Interior.ColorIndex = xlNone .SpecialCells(1).Interior.ColorIndex = CLR End With End Sub1 point
-
انسخ الشفرة التالية وضعها في حدث عند النقر لزر الأمر Dim DB As DAO.Database Set DB = CurrentDb() '--- DB.Execute "SELECT * INTO [عناوين المرضى] IN'" _ & CurrentProject.Path & "\Patients.xlsx'[Excel 12.0;HDR=yes;READONLY=FALSE] FROM TABLE1 " '--- DB.Execute "SELECT * INTO [حالة العلاج] IN'" _ & CurrentProject.Path & "\Patients.xlsx'[Excel 12.0;HDR=yes;READONLY=FALSE] FROM TABLE2 "1 point
-
1 point
-
1 point
-
بسيطة استبدل الكود بهذا الكود Sub test() Dim a As Variant Dim m As Object Dim r, i r = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row With CreateObject("VBScript.RegExp") .Global = True .Pattern = "(\d.*\d)" For i = 2 To r Set m = .Execute(Cells(i, 3)) a = Split(m(0), "*") Cells(i, 3).Offset(, 1) = a(0) * a(1) Next End With End Sub سليم (2).xlsm1 point
-
عليكم السلام Private Sub endpage_Click() strSql = "SELECT * FROM tblData WHERE tblData.ID > ( (select COUNT(*) from tblData) - 10)" Me.RecordSource = strSql End Sub Private Sub firstpage_Click() strSql = "SELECT TOP 10 tblData.ID, tblData.[NO], tblData.Locatin, tblData.SecName, tblData.DepName, tblData.RegDate FROM tblData WHERE (((tblData.ID)>=1))" Me.RecordSource = strSql End Sub السجلات في النموذج .mdb1 point
-
بالخدمة استاذ أبو يحيى الجبلاوي تصميم صندوق-2.rar1 point
-
كشف 12 للصف السادس الابتدائي ------------------------------------------------------ ------------------------------------------------------ ------------------------------------------------------ https://cutt.ly/thychh1 point
-
مشاركة مع حبيبنا الاستاذ . حسام استبدل الكود بهذا >>>>>> If Me.m1.ListCount = 0 Then Me.m1.AddItem "م" & ";" & "الصنف" & ";" & "عدد" & ";" & "المبلغ" Me.m1.AddItem Me.id & ";" & Me.tex_snf & ";" & Me.tex_count & ";" & Me.tex_ammount Else Me.m1.AddItem Me.id & ";" & Me.tex_snf & ";" & Me.tex_count & ";" & Me.tex_ammount End If Dim i As Long, SumTotal As Long SumTotal = 0 For i = 1 To (Me.m1.ListCount - 1) SumTotal = SumTotal + Nz(Me.m1.ItemData(i), 0) Next i txtTotal = SumTotal1 point
-
1 point
-
كان وضعت مثال للتطبيق .... على كل حال جرب الكود التالي .... أو ارفق ملفك للتعديل . On Error Resume Next If IsNull(Me.readtbl.Column(0)) Then MsgBox "The List Empty or Items in list not selected", vbCritical, "Caution" Exit Sub End If Me.ProgBar.Visible = True Dim x As Integer For x = x To 30000 Me.ProgBar.Value = x If x = 30000 Then Me.ProgBar.Visible = False End If Next x Dim i As Integer Dim tbl As String Dim SDest As String Dim SFileName As String SDest = Me.txtPath SFileName = Me.txtFileName For i = 0 To Me.readtbl.ListCount - 1 If Me.readtbl.Selected(i) = True Then tbl = Me.readtbl.Column(0, i) DoCmd.TransferSpreadsheet acExport, , tbl, SDest & "\" & SFileName & ".xlsx" End If Next i MsgBox "تم بحمد الله الانتهاء من عملية التصدير ", 0 + 64 + 1572864, "مبروك"1 point
-
1 point
-
بارك الله فيك استاذ محي ولإثراء الموضوع يمكنك استخدام هذه المعادلة المعرفة وهذا هو كودها Function Evals(t As String) As Double Dim c As String, i As Long For i = 1 To Len(t) If Asc(Mid(t, i, 1)) < 58 And Asc(Mid(t, i, 1)) > 41 Then c = c & Mid(t, i, 1) Next Evals = Evaluate(c) End Function ثم تكتب المعادلة بالخلية B2 على النحو التالى : =Evals(A2) سليم1.xlsm1 point
-
تشرفنا يا بلديات - الصعايدة اذا احتلو منصات البرمجة - إذا ما يكرسوفت ستعلن افلاسها عن قريب أو ستبيع شركتها لواحدة من شركات الصعايدة - أنا صعيدي وأفتخر (بالاسلام طبعا ) علي فكرة أنا لا خبير ولا حاجة أنا لسه طالب علم علي أول الطريق وقد تخلفت عن الركب كثيرا فقد سبقني غيري الي حيث لا أعلم من دروب العلم بهذا المجال تمنياتي بالتوفيق الدائم ولا تتردد في طرح تسائلاتك هنا فمن هنا حصلنا علي علم كثير لم نعمل به (ولا تصنع مثلي في عدم الاستفادة من علم الاساتذة علي الوجه المرجو هذه نصيحة )1 point
-
1 point
-
تفضل هذا الكود شامل الشرح اخي الكريم On Error GoTo errorhandle Dim MyFilePath, MyRange, MyTablName As String 'MyFilePath = "مسار ملف الاكسل" MyRange = "نطاق الخلايا المراد استيرادها من ملف الاكسل" MyTablName = "اسم الجدول الذي سيتم تخزين البياناته به" '-------------------------------- '''''''' فتح مستعرض الملفات لإختيار الملف '''''''' Dim fpath As Variant With Application.FileDialog(3) .Title = "Choose File" .Filters.Clear .Filters.Add "Excel Files", "*.xls ; *.xlsx" .AllowMultiSelect = False .InitialFileName = "" If .Show = -1 Then MyFilePath = .SelectedItems(1) End If End With '-------------------------------- '''''''' استيراد ملف الاكسل حسب الشروط اعلاه '''''''' DoCmd.TransferSpreadsheet acImport, 10, MyTablName, FilePath, False, MyRange MsgBox "تم استيراد الملف بنجاح", vbMsgBoxRight + vbInformation, "تأكيد" errorhandleexit: Exit Sub errorhandle: MsgBox Err.Description Resume errorhandleexit1 point
-
1 point
-
هذه محاولة لتنفيذ الفكرة وحيث ان الحدث يتم تنفيذه عند النقر فهناك مشكلة متوقعة خاصة بالتعديل حيث انه قد بتم النقر و لا يكون هناك تعديل اصلا وأرى لتلافي هذه المشكلة ان يتم حماية الحقول حال فتح النموذج ويتم فك الحماية بالنقر المزدوج على الخلية لضمان والتأكد من ان الحركة مقصودة للتعديل User1.rar1 point