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

غدا سارفع ملف توضيح للمطلوب قبل التنفيذ والنتيجة تقبل تحياتي

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

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

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

اعتذر عن المتابعة أخي الكريم ، عل أحد الإخوة والأساتذة يفيدك في تحقيق مطالبك والتعامل مع المسميات باللغة العربية بشكل أفضل مني .

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

وعليكم السلام اخي الكريم لا اخي الكريم ال sql مجانية

وعليكم السلام ورحمة الله تعالى وبركاته اخي @أبو أحمد ، تفضل الكود التالي بعد تعديل المسميات في مثالك. Private Sub أمر26_Click() On Error GoTo ErrorHandler Dim db As dao.Database Dim rst1 As Recordset, rst2 As Recordset Dim fld As Field Dim sqlUpdate1 As String, sqlUpdate2 As String Dim recordID As Long If Me.searinumber = 0 Or IsNull(Me.searinumber) Or Me.searinumber = "" Then MsgBox "الرجاء إدخال رقم السجل", vbExclamation Me.searinumber.SetFocus Exit Sub End If recordID = Val(Me.searinumber) Set db = CurrentDb() If DCount("*", "جدول تسجيل الكتب", "searinumber = " & recordID) = 0 Then MsgBox "رقم السجل غير موجود", vbExclamation Me.searinumber.SetFocus GoTo ExitSub End If Set rst1 = db.OpenRecordset("جدول تسجيل الكتب") 'الجدول الرئيسي sqlUpdate1 = "UPDATE [جدول تسجيل الكتب] SET " For Each fld In rst1.Fields If fld.Name <> "searinumber" Then 'المفتاح الأساسي If Not (fld.Attributes And dbAutoIncrField) Then sqlUpdate1 = sqlUpdate1 & "[" & fld.Name & "] = Null, " End If End If Next fld If Right(sqlUpdate1, 2) = ", " Then sqlUpdate1 = Left(sqlUpdate1, Len(sqlUpdate1) - 2) sqlUpdate1 = sqlUpdate1 & " WHERE searinumber = " & recordID End If Set rst2 = db.OpenRecordset("Marks") 'الجدول الفرعي sqlUpdate2 = "UPDATE Marks SET " For Each fld In rst2.Fields If fld.Name <> "NoMArks" Then 'الحقل المرتبط If Not (fld.Attributes And dbAutoIncrField) Then sqlUpdate2 = sqlUpdate2 & "[" & fld.Name & "] = Null, " End If End If Next fld If Right(sqlUpdate2, 2) = ", " Then sqlUpdate2 = Left(sqlUpdate2, Len(sqlUpdate2) - 2) sqlUpdate2 = sqlUpdate2 & " WHERE NoMArks = " & recordID End If db.Execute sqlUpdate1 db.Execute sqlUpdate2 MsgBox "تمت تصفية بيانات السجل رقم " & recordID & " في الجدولين", vbInformation Me.Requery ExitSub: If Not rst1 Is Nothing Then rst1.Close If Not rst2 Is Nothing Then rst2.Close Set rst1 = Nothing Set rst2 = Nothing Set db = Nothing Exit Sub ErrorHandler: MsgBox "حدث خطأ", vbCritical Resume ExitSub End Sub

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub SaveAsPDF() Dim CrWS As Worksheet: Set CrWS = Sheets("بيانات") Dim lastRow As Long: lastRow = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row Dim xPath As String: xPath = ThisWorkbook.Path & "\كشف_التلاميذ.pdf" CrWS.Range("A2:J" & lastRow).ExportAsFixedFormat Type:=xlTypePDF, Filename:=xPath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub

السلام عليكم جرب التعديل في الملف Option Explicit Sub CircleLowGrades() Dim ws As Worksheet Dim gradeRanges As Variant Dim maxRanges As Variant Dim cell As Range Dim maxCell As Range Dim maxGrade As Double Dim shp As Shape Dim i As Integer, j As Integer Dim gradeRange As Range, maxRange As Range Set ws = ThisWorkbook.Sheets("شهادةنصف") gradeRanges = Array(ws.Range("D13:P13"), ws.Range("D30:P30"), ws.Range("D47:P47")) maxRanges = Array(ws.Range("D12:P12"), ws.Range("D29:P29"), ws.Range("D46:P46")) For Each shp In ws.Shapes If shp.Name Like "Circle*" Then shp.delete Next shp For i = LBound(gradeRanges) To UBound(gradeRanges) Set gradeRange = gradeRanges(i) Set maxRange = maxRanges(i) For j = 1 To gradeRange.Cells.Count Set cell = gradeRange.Cells(j) Set maxCell = maxRange.Cells(j) If IsNumeric(maxCell.Value) Then maxGrade = Val(maxCell.Value) Else maxGrade = 0 End If If IsNumeric(cell.Value) Then If Val(cell.Value) < maxGrade Then Call DrawCircle(ws, cell) End If ElseIf cell.Value = "غ" Or cell.Value = "غـ" Or cell.Value = "صفر" Then Call DrawCircle(ws, cell) End If Next j Next i End Sub Sub DrawCircle(ws As Worksheet, cell As Range) Dim shp As Shape Set shp = ws.Shapes.AddShape(msoShapeOval, cell.Left + 2, cell.Top + 2, cell.Width - 4, cell.Height - 4) shp.Name = "Circle" & cell.Address(False, False) shp.Line.ForeColor.RGB = RGB(255, 0, 0) shp.Fill.ForeColor.RGB = RGB(255, 255, 255) shp.Fill.Transparency = 1 End Sub test1.xlsb

في موضوع لاخي الكريم // مؤمن جمعة (عمل لوحه UserForm بترحيل بيانات) علي الرابط التالي http://www.officena.net/ib/index.php?showtopic=49583&hl= وطلبه لتصميم برنامج لمتابعة حركة السيارات وتسجيل العمليات المتعلقة ونظرا لان عنوان الموضوع لا يدل علي محتواه وبعد اذن ادارة المنتدي طرحت الموضوع بشكل منفصل حتي يكون في متناول الجميع ولسهولة البحث بعد ذلك بالمنتدي الكريم ويمكن تعديل القاعدة لتتلائم مع شركات تاجير السيارات واضافة حساب كيلومترات السيارة وتكلفة الايجار علي حسب الحاجة وادعوا الله ان يكون الموضوع فيه الفائدة للسائل او الباحث شرح موجز لوظائف الفورم ولا تنسونا بدعوة بظاهر الغيب بصلاح الحال متابعة السيارات.rar

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

السلام عليكم ورحمة الله وبركاته تم إضافة المعادلات اللازمة لحساب ما تبقى من أيام لغاية تاريخ تجديد العقد الموالي للتاريخ الحالي (والعداد التنازلي يبدأ انطلاقا من 90 يوم كما طلبت)... أرجو أن تفي الغرض المطلوب... بن علية حاجي طلب عداد بقرب انتهاء عقد.rar

أخي الكريم بسام أهلاً بك في المنتدى ونورت بين إخوانك ونتمنى لك قضاء أمتع الأوقات معنا إليك الملف المرفق الأخير الذي يحتوي على تعديلات الأخ الحبيب ضاحي .. قم بالنقر على اسم الملف سيظهر معك نافذة برنامج التحميل ..حدد المكان المراد حفظ الملف فيه ، وبعد التنزيل يمكنك فك الضغط عن الملف باستخدام برنامج الوينرار تقبل تحياتي متابعة السيارات.rar

أليك هذا اخى مجرب salary finished.rar

السلام عليكم تم حماية الشيتات من الحذف أو الإضافة تم منع خاصيتي النسخ واللصق شاهد المرفق ==== جاري العمل على حل مشكلة التاريخ salary finished.rar

السلام عليكم في البداية جرب المرفق 1. لا يمكن حفظ الملف بأي صيغة اخرى 2. الملف لا يعمل اذا كان الامان منخفض 3. لا يمكن التعديل على الملف === بالنسبة للتاريخ يمكن التحكم فيه لو كان ما سبق يناسبك Abu_Ahmed.rar

بسم الله الرحمن الرحيم و هذا مثال مايكروسوفت الذى تجده بHelp Example ". وقد قمت بالتعديل عليه لاظهار ايام الاسبوع عن طريق Array بالكود التالى Sub DOIT() Dim MyWeek, MyDay MyWeek = Array("Sat", "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun") For i = 0 To 6 MyDay = MyWeek(i) MsgBox (MyDay) Next i End Sub مع ملاحظه اننا قمن بمناداه ايام الاسبوع بعد تعريفها MyDay بوضعها بين قوسين مرفق ملف السلام عليكم Array.rar

تفضل لعله المطلوب إن شاء الله ok المصنف1.xlsb