بحث مخصص من جوجل فى أوفيسنا
![]()
Custom Search
|
نجوم المشاركات
Popular Content
Showing content with the highest reputation on 24 يون, 2024 in all areas
-
السلام عليكم 🙂 هذا الموقع يعطي ترتيب أكثر قواعد بيانات العالم استخداما: https://db-engines.com/en/ranking/relational+dbms والترتيب متغير شهريا ، ففي هذا الشهر: 6/2024 ، يكون ترتيب الاكسس رقم 8 عالميا : . واليكم طريقة تقييمهم للترتيب من: https://db-engines.com/en/ranking_definition وهنا تمت ترجمته آليا الى العربية: جعفر5 points
-
اخي بما انك تريد انشاء قاعدة بيانات لتعبئة عناصر اليوزرفورم بشكل ديناميكي ومترابط اسهل طريقة بالنسبة لك هي انشاء جدول على ورقة Compte magasin يتضمن جميع الاعمدة المرغوب الاشتغال عليها مع حدف جميع الاعمدة الفارغة وتسميته مثلا ب Table1 واستبدال الاكواد الموجودة على النمودج لديك بالكود التالي شكل الملف بعد التعديل '24/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' Dim a, i As Long Dim d As Object, ComboAry As Variant Private Const Cpt As String = "Compte magasin" Private Const tbl As String = "Table1" Private Sub UserForm_Initialize() a = Sheets(Cpt).ListObjects("Table1").DataBodyRange.Columns("A:X") Set d = CreateObject("scripting.dictionary") d.CompareMode = vbTextCompare ComboAry = Array("ComboBox1", "ComboBox3", "ComboBox5", "ComboBox9", "ComboBox12") For i = 0 To UBound(ComboAry): Me.Controls(ComboAry(i)).value = "*": Next i End Sub Private Sub ComboBox1_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 2)) = "*" Next ComboBox1.List = d.keys End Sub Private Sub ComboBox2_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 2)) = UCase(ComboBox1.value) Then d(a(i, 3)) = "*" Next ComboBox2.List = d.keys End Sub Private Sub ComboBox3_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 21)) = "*" Next ComboBox3.List = d.keys End Sub Private Sub ComboBox4_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 21)) = UCase(ComboBox3.value) Then d(a(i, 22)) = "*" Next ComboBox4.List = d.keys End Sub Private Sub ComboBox5_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 23)) = "*" Next ComboBox5.List = d.keys End Sub Private Sub ComboBox11_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 23)) = UCase(ComboBox5.value) Then d(a(i, 24)) = "*" Next ComboBox11.List = d.keys End Sub Private Sub ComboBox9_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 19)) = "*" Next ComboBox9.List = d.keys End Sub Private Sub ComboBox8_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 19)) = UCase(ComboBox9.value) Then d(a(i, 18)) = "*" Next ComboBox8.List = d.keys End Sub Private Sub ComboBox12_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) d(a(i, 4)) = "*" Next ComboBox12.List = d.keys End Sub Private Sub ComboBox13_DropButtonClick() Dim i As Long d.RemoveAll For i = LBound(a) To UBound(a) If UCase(a(i, 4)) = UCase(ComboBox12.value) Then d(a(i, 5)) = "*" Next ComboBox13.List = d.keys End Sub '************************* Private Sub ComboBox1_Change() ComboBox2.value = "*" End Sub Private Sub ComboBox3_Change() ComboBox4.value = "*" End Sub Private Sub ComboBox5_Change() ComboBox11.value = "*" End Sub Private Sub ComboBox9_Change() ComboBox8.value = "*" End Sub Private Sub ComboBox12_Change() ComboBox13.value = "*" End Sub2 points
-
2 points
-
1 point
-
اسعد الله ايامك ولياليك تمام ولا اجمل .. برنامج احترافي لإعداد وحفظ وطباعة .. الكلمات المتقاطعة ( تعلم بطريقة اللعب والتسلية) جزاك الله خيرا واحسن اليك1 point
-
السلام عليكم بما ان النموذج فردي single form فالسبب ان النموذج المحذوف مفتوح اذا كان نموذج مستمر فالمفترض بعد الامر requery يختفي السجل المحذوف ولكن في هذه الحاله يجب اغلاق النموذج بعد الحذف او الانتقال لسجل جديد او السجل التالي حسب المفضل لك1 point
-
1 point
-
فى قاعده التحقق من الصحة الحقول اللى عايز تعملها اكتب Is Not Null1 point
-
ممكن من خلال الكود التالي Private Sub btnAdd_Click() Dim db As DAO.Database Dim rs As DAO.Recordset Dim fixedNameValue As String Dim newResultValue As String ' الحصول على القيم من الحقول fixedNameValue = Me.Fixedname newResultValue = Me.Newresult ' التحقق من أن القيم ليست فارغة If IsNull(fixedNameValue) Or IsNull(newResultValue) Then MsgBox "يرجى ملء جميع الحقول قبل الإضافة.", vbExclamation Exit Sub End If ' فتح قاعدة البيانات Set db = CurrentDb ' فتح الجدول المراد الإضافة إليه Set rs = db.OpenRecordset("fixedresult_tbl", dbOpenDynaset) ' إضافة سجل جديد rs.AddNew rs!Fixedname = fixedNameValue rs!Fixedresult = newResultValue rs.Update ' إغلاق مجموعة السجلات rs.Close Set rs = Nothing Set db = Nothing ' إبلاغ المستخدم بالنجاح MsgBox "تمت الإضافة بنجاح!", vbInformation End Sub1 point
-
هل جربت شيء كهدا If WS.Range("DZ" & j) Like clé or WS.Range("DZ" & j) like "غ" then1 point
-
دا نورك يا خال انا كان بقالي يجي بتاع ٤ سنين هنا وكنت ناسي الرقم السري ☺️☺️☺️1 point
-
1 point
-
تفاديا للاخطاء لا تنسى تغديل السطر الخاص بافراغ البيانات السابقة الى f.Range("D11:R" & f.Rows.Count).ClearContents1 point
-
1 point
-
اخي الكريم المسالة سهلة يكفي تحديد العمود المرغوب نسخ بياناته في السطر الاول مع تحديد خلية بداية اللصق في السطر الثاني ' Sheets("نتيجةت4")اسماء الاعمدة المرغوب ترحيلها OneRng = Array("F13:F" & a, "H13:H" & a, "J13:J" & a, "l13:l" & a, "N13:N" & a, "P13:P" & a, _ "R13:R" & a, "U13:U" & a, "W13:W" & a, "Y13:Y" & a, "AA13:AA" & a, "AC13:AC" & a, "AE13:AE" & a, _ "A13:A" & a) '<=======عمود المسلسل======== ' خلية اللصق Sheets("نتيجة تقييم41") arr = Array("E11", "F11", "G11", "H11", "I11", "J11", "K11", "L11", "M11", "N11", "O11", "P11", "Q11", _ "D11")'<=====اول خلية على عمود تاريخ الميلاد======== تحويل الى كود V3.xlsm1 point
-
وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا الحل ربما يناسبك Sub CopyRanges() Dim i As Long, a As Long, lr As Long Dim OneRng As Variant, arr As Variant, Irow As Long, C As Long Dim oldData() As Variant, newData() As Variant Dim xlnCalcMethod As XlCalculation Dim WS As Worksheet: Set WS = Sheets("نتيجةت4") Dim f As Worksheet: Set f = Sheets("نتيجة تقييم41") Irow = f.Cells.SpecialCells(xlCellTypeLastCell).Row oldData = Array("غ", "ازرق", "اخضر", "اصفر", "احمر") newData = Array("لم يتقن المعارف", "يفوق التوقعات", "امتلك المعارف والمهارات", "يحتاج لبعض الدعم", "لم يتقن المعارف") a = WS.Columns("E:AE").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row With Application xlnCalcMethod = .Calculation .Calculation = xlCalculationManual .EnableEvents = False .ScreenUpdating = False f.Range("E11:R" & f.Rows.Count).ClearContents OneRng = Array("F13:F" & a, "H13:H" & a, "J13:J" & a, "l13:l" & a, "N13:N" & a, "P13:P" & a, _ "R13:R" & a, "U13:U" & a, "W13:W" & a, "Y13:Y" & a, "AA13:AA" & a, "AC13:AC" & a, "AE13:AE" & a) arr = Array("E11", "F11", "G11", "H11", "I11", "J11", "K11", "L11", "M11", "N11", "O11", "P11", "Q11") For i = 0 To UBound(OneRng) WS.Range(OneRng(i)).Copy f.Range(arr(i)).PasteSpecial xlPasteValues Application.CutCopyMode = False Next lr = f.Columns("E:Q").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Set Rng = f.Range("E11:Q" & lr) For C = LBound(oldData) To UBound(oldData) Rng.Replace oldData(C), newData(C), xlWhole, , , , False, False Next With f.Range("R11:R" & lr) .Formula = "=IF(" & WS.Name & "!F13="""",""""," & WS.Name & "!AF13)" .Value = .Value End With .Calculation = xlnCalcMethod .EnableEvents = True .ScreenUpdating = True End With End Sub تحويل الى كود V2.xlsm1 point
-
لديك اخطاء في تحديد اسماء الخلايا كما في الصورة المرفقة تم تعديل الكود ليسهل التعامل معه Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet Dim Irow As Long, Clé As String, i As Long Set WS = Sheets("Sheet2"): Set F = Sheets("Sheet1"): Clé = F.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub Irow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row Set rng = WS.Range("B3:B" & Irow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then: MsgBox " الاسم غير موجود", vbExclamation, Clé: Exit Sub For i = 3 To Irow If WS.Cells(i, 2) = Clé Then ' Colmun (D) F.[D5] = WS.Cells(i, "B") F.[D7] = WS.Cells(i, "C"): F.[D9] = WS.Cells(i, "D"): F.[D11] = WS.Cells(i, "E") F.[D13] = WS.Cells(i, "F"): F.[D15] = WS.Cells(i, "G"): F.[D17] = WS.Cells(i, "H") F.[D19] = WS.Cells(i, "I"): F.[D21] = WS.Cells(i, "J"): F.[D23] = WS.Cells(i, "K") ' Colmun (G) F.[G7] = WS.Cells(i, "L"): F.[G9] = WS.Cells(i, "M"): F.[G11] = WS.Cells(i, "N") F.[G13] = WS.Cells(i, "O"): F.[G15] = WS.Cells(i, "P"): F.[G17] = WS.Cells(i, "Q") F.[G19] = WS.Cells(i, "R"): F.[G21] = WS.Cells(i, "S"): F.[G23] = WS.Cells(i, "T") ' Colmun (J) F.[J7] = WS.Cells(i, "U") F.[J9] = WS.Cells(i, "V"): F.[J11] = WS.Cells(i, "W") F.[J13] = WS.Cells(i, "X"): F.[J15] = WS.Cells(i, "Y") End If Next Application.ScreenUpdating = True End Sub مع تعديل كود الترحيل بالشكل التالي Private Sub CommandButton1_Click() ' اظافة Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 24).Value = Application.Index(WS.Range _ ("D5,D7,D9,D11,D13,D15,D17,D19,D21,D23,G7,G9,G11,G13,G15,G17,G19,G21,G23,J7,J9,J11,J13,J15"), _ 1, 1, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A3:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With Lr = F.Range("A65500").End(xlUp).Row b = F.Cells(2, F.Columns.Count).End(xlToLeft).Column F.Range(F.Cells(3, 1), F.Cells(Lr, b)).Borders.Weight = xlThin ' افراغ CommandButton4_Click Application.ScreenUpdating = True MsgBox "تم اضافة البيانات بنجاح" End Sub 123 (1).xlsm1 point
-
هدا ملف مغاير اخي الكريم على العموم تفضل هده الاكواد الخاصة بك بعد تعديلها Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet, J As Long Dim rng As Range, LastRow As Long, Clé As String Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2"): Clé = WS.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub LastRow = F.Cells(F.Rows.Count, "B").End(xlUp).Row Set rng = F.Range("B3:B" & LastRow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then MsgBox " الاسم غير موجود", vbExclamation, Clé Else J = rng.Row WS.[D5].Value = F.Cells(J, 2).Value: WS.[D7].Value = F.Cells(J, 3).Value WS.[D9].Value = F.Cells(J, 4).Value: WS.[D11].Value = F.Cells(J, 5).Value WS.[D13].Value = F.Cells(J, 6).Value: WS.[D15].Value = F.Cells(J, 7).Value WS.[D17].Value = F.Cells(J, 8).Value: WS.[D19].Value = F.Cells(J, 9).Value WS.[D21].Value = F.Cells(J, 10).Value: WS.[D23].Value = F.Cells(J, 11).Value WS.[G7].Value = F.Cells(J, 12).Value: WS.[G9].Value = F.Cells(J, 13).Value WS.[G11].Value = F.Cells(J, 14).Value: WS.[G13].Value = F.Cells(J, 15).Value WS.[G15].Value = F.Cells(J, 16).Value: WS.[G17].Value = F.Cells(J, 17).Value WS.[G19].Value = F.Cells(J, 18).Value: WS.[G21].Value = F.Cells(J, 19).Value WS.[G23].Value = F.Cells(J, 20).Value Application.ScreenUpdating = True End If End Sub اما بالنسبة لكود التعديل يمكنك اتمامه بنفس الطريقة Private Sub CommandButton5_Click() 'تعديل Dim WS As Worksheet, WS2 As Worksheet Dim LastRow As Long, i As Long Set WS = Sheets("Sheet2"): Set WS2 = Sheets("Sheet1") LastRow = WS.Cells(WS.Rows.Count, 2).End(xlUp).Row For i = 3 To LastRow If WS.Range("B" & i).Value = WS2.[E3] Then WS.Range("B" & i) = WS2.Range("D5") WS.Range("C" & i) = WS2.Range("D7") WS.Range("D" & i) = WS2.Range("D9") WS.Range("E" & i) = WS2.Range("D11") WS.Range("F" & i) = WS2.Range("D13") 'اتمم الكود '''''''''''''''''''' '''''''''''''''''''' MsgBox "تم تعديل البيانات بنجاح" End If Next i Application.ScreenUpdating = True End Sub 123.xlsm1 point
-
جرب هل هدا ما تقصده Sub TEST() Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("ورقة2"): Set F = Sheets("ورقة3") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 26).Value = Application.Index(WS.Range _ ("D5,C7,C9,C11,D13,E15,D17,D19,D21,J7,J9,J11,J13,J15,J17,I19,K19,J21,O7,O9,O11,N13,N15,N17,O19,O21"), _ 1, 1, Array(2, 3, 1, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A4:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-3") End With Application.ScreenUpdating = True MsgBox "تم ترحيل البيانات بنجاح" End Sub New ورقة عمل Microsoft Excel 2.xlsm1 point
-
اعتذر لرفع ملف تجريبي . اليك المرفق بعد التجريب . هل اشتغل معك ظهور ملفات PDF من قبل ؟ . اذا كان شغال يبقى المشكله كانت في الترقيم المتكرر . واحنا حليناها . DDAdd&DeletePDF.LAST.rar1 point