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

يمكننا ضبط الكود لتحقيق ذلك. يتم وضع كل اسم في خلية واحدة، والأسماء المختلفة تُفصل بواسطة سطر جديد في نفس الخلية. اليك الكود المعدل Private Sub Workbook_Open() ' جعل الصفحة من اليمين والتنسيق في المنتصف With ActiveWindow .WindowState = xlMaximized .DisplayRightToLeft = True End With ' تنسيق الأرقام بخط عريض بحجم 14 Cells.NumberFormat = "0" Cells.Font.Size = 14 ' تنسيق العمود A برقم مخصص 000000 Columns("A").NumberFormat = "000000" ' تنسيق العمود B بتكست Columns("B").NumberFormat = "@" ' تقسيم الأسماء في العمود C Dim lastRow As Long lastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow Dim fullNameA As String Dim fullNameB As String Dim combinedNames As String ' قراءة الأسماء من العمود A و B fullNameA = Cells(i, "A").Value fullNameB = Cells(i, "B").Value ' المقارنة والتحقق من الأسماء المتطابقة If InStr(fullNameB, fullNameA) > 0 Or InStr(fullNameA, fullNameB) > 0 Then combinedNames = fullNameA Else combinedNames = fullNameA & vbCrLf & fullNameB End If ' وضع الأسماء في العمود C Cells(i, "C").Value = combinedNames Next i End Sub

وعليكم السلام. للأسف، عندما يتم تحميل ملف إكسل على Google Drive، قد يتم فقدان بعض خصائص الحماية التي قمت بها في الكمبيوتر. هذا يعود إلى طريقة عمل Google Drive وتفاعله مع ملفات Office. للتحكم بصلاحيات الوصول على Google Drive، يفضل استخدام خيارات الحماية المتوفرة على المستوى الخاص بـ Google Drive نفسه، بدلاً من الاعتماد فقط على حماية الورقة أو الخلية داخل الملف. يمكنك قفل ملفك على Google Drive من خلال اختيار الخيارات المناسبة في واجهة Google Drive. لتقديم الوصول بصورة قراءة فقط، اختار "مشاركة" ثم "حدد الذين يمكنهم الوصول" وحدد "قارئ" بدلاً من "محرر".

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

بارك الله فيك وزادك علما يارب تعبت حضرتك معايا

فعلا غريب سابحث في هذا الموضوع و اوافيك ان شاءالله

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

في الكود أدناه، يتم مقارنة الأسماء في العمود A والعمود B، وإذا كانت الأسماء متطابقة، يُكتب الاسم في العمود C، وإذا كانت مختلفة، يتم فصلها تمامًا في العمود 😄 Private Sub Workbook_Open() ' جعل الصفحة من اليمين والتنسيق في المنتصف With ActiveWindow .WindowState = xlMaximized .DisplayRightToLeft = True End With ' تنسيق الأرقام بخط عريض بحجم 14 Cells.NumberFormat = "0" Cells.Font.Size = 14 ' تنسيق العمود A برقم مخصص 000000 Columns("A").NumberFormat = "000000" ' تنسيق العمود B بتكست Columns("B").NumberFormat = "@" ' تقسيم الأسماء في العمود C Dim lastRow As Long lastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow Dim fullNameA As String Dim fullNameB As String ' قراءة الأسماء من العمود A و B fullNameA = Cells(i, "A").Value fullNameB = Cells(i, "B").Value ' المقارنة والفصل في العمود C If InStr(fullNameB, fullNameA) > 0 Or InStr(fullNameA, fullNameB) > 0 Then Cells(i, "C").Value = fullNameA Else Cells(i, "C").Value = fullNameA & " / " & fullNameB End If Next i End Sub

امين واياك ....

طيب <><><><><><> اكيد مع عمل البرنامج تظهر عبارات اخرى ..... على العموم اضفت مصفوفة يمكن من خلالها اضافة عبارات اخرى Private Sub ComboBox1_Change() Dim lastChar As String lastChar = Right(ComboBox1.Text, 1) myT = Array("مدام", "عبارة1", "عبارة2") For Each t In myT If t = ComboBox1.Value Then TT = t: Exit For End If Next t If ComboBox1.Value = TT Or lastChar = "ه" Or lastChar = "ة" Then ComboBox2.SetFocus: ComboBox2.Text = "female" Else ComboBox2.SetFocus: ComboBox2.Text = "male" End If End Sub

الله يجزيك الخير أفدتني اكثر من طلبي

السلام عليكم جرب الكود التالي Option Compare Database Option Explicit Private Sub EnablePropertySheet() Dim obj As Object For Each obj In CommandBars If obj.Index < 10 Then obj.Enabled = True End If Next obj End Sub Private Sub DisablePropertySheet() Dim obj As Object For Each obj In CommandBars If obj.Index < 10 Then obj.Enabled = False End If Next obj End Sub Private Sub BtnOn_Click() On Error GoTo ErrHandler CommandBars("Property Sheet").Enabled = True ErrHandler: If Err Then Call EnablePropertySheet End Sub Private Sub BtnOff_Click() On Error GoTo ErrHandler CommandBars("Property Sheet").Enabled = False ErrHandler: If Err Then Call DisablePropertySheet End Sub مجرد تعديل بسيط على كود الاستاذ ابو جودي. لقد جربته الان على نسخة 2021 ويعمل بكفاءه. واليك المرفق بالتوفيق property sheet visible or not _ UP V2.mdb

Sub test() Dim Sh As Worksheet: Dim WS As Worksheet: Set WS = Worksheets("data") Dim I&, F As Range For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> WS.Name Then Application.ScreenUpdating = False For I = 3 To WS.Range("E" & Rows.Count).End(xlUp).Row If WS.Cells(I, "E") = Sh.Name Then WS.Range("A2:E2").Copy Destination:=Sh.Range("A1") Set F = WS.Range(WS.Cells(I, 1), WS.Cells(I, 5)) F.Copy Destination:=Sh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) With Sh.Range("A2:E" & Sh.Range("A" & Rows.Count).End(xlUp).Row) .Interior.Color = xlNone: .EntireColumn.AutoFit End With End If Next I End If Next Sh Application.ScreenUpdating = True End Sub

عذرا أخي @figo82eg إنشغلنا بإجازة العيد 😅 .. تفضل التعديل : بعدها يتم حذف المجلد [ 1 ] والخاص بالسجل رقم 1 بالكامل بما فيه من ملفات 🙂 وهذا الكود المرتبط بزر الحذف : Private Sub DltBtn_Click() Dim DesPath As String Dim D As String: D = "\" DesPath = BECurrentPath & D & Me.InOut & D & Me.Department & D & Me.DocType & D & Me.ID If IsFileExists(DesPath) = False Or IsBlank(Me.FileName) = True Then MsgBox "لا يمكن العثور على الملف", vbOKOnly, "": Exit Sub On Error Resume Next If MsgBox("هل حقا تريد حذف الملفات المرتبطة ؟", vbYesNo, "") = vbYes Then DleteFolder DesPath Me.FileName = "" Me.ImageBox.Requery End If End Sub وفي حدث عند الحذف للنموذج تضع هذا الأمر : Private Sub Form_Delete(Cancel As Integer) DltBtn_Click End Sub مع الحاجة لإضافة هاتين الدالتين في موديول ( أنا أضفتها للموديول المسمى FilesHandlingModule ) : Public Function DleteFolder(FolderPath As String) Dim fs Set fs = CreateObject("Scripting.FileSystemObject") fs.DeleteFolder FolderPath, True Set fs = Nothing End Function '----------------------------------------------------------------------------- ' True if the argument is Nothing, Null, Empty, Missing or an empty string . '----------------------------------------------------------------------------- Public Function IsBlank(arg As Variant) As Boolean Select Case VarType(arg) Case vbEmpty IsBlank = True Case vbNull IsBlank = True Case vbString IsBlank = (LenB(arg) = 0) Case vbObject IsBlank = (arg Is Nothing) Case Else IsBlank = IsMissing(arg) End Select End Function AttachFilesToDB.rar