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

انا بقي بعد اكثر من سنه ونصف او اكثر شوي على وندوز 11 رجعت ل 10 علشان وحشني 😁 (وعلشان حسيت وندوز 11 بدأ يتغابي معايا ولقيت نفسي باعاني معاه فقولت الطلاق افضل ورجعت لام عيالى وندوز 10) ^_^

هذا البرنامج هو لحساب المواريث والوصايا بالاكسل يمكن تشغيله بالنقال الذكى ..او الحاسوب نسخة 2024 اعداد الفرضى المهندس خالد الطاهر حدادة عنوان البريد الإلكتروني khaledhadada47@gmail.com ليبيا الفرائض_الربانية_بالجداول_الالكترونية_2024.xlsx

وعليكم السلام ورحمة الله وبركاته .. تفضل هذه الفكرة :- Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, valToCheck, foundCell As Range On Error Resume Next Set c = Intersect(Target, Columns("E")) If c Is Nothing Then Exit Sub Application.EnableEvents = False valToCheck = c.Value If valToCheck <> "" Then Set foundCell = Columns("E").Find(valToCheck, LookIn:=xlValues) If Not foundCell Is Nothing And foundCell.Row <> c.Row Then If WorksheetFunction.CountBlank(Range("K" & foundCell.Row & ":N" & foundCell.Row)) = 4 Then MsgBox "الحالة سبق ادخالها ولم يتم بشانها اجراء", vbExclamation + vbMsgBoxRight, "تنبيه" c.ClearContents End If End If End If Application.EnableEvents = True End Sub Book1.zip

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

اعرض الملف تخصيص العلامة المائية للتقارير بطريقتين {سلسلة الأدوات المساعدة المخصصة} تقوم هذه الأداة بتخصيص العلامة المائية للتقارير بطريقتين - إما أن تكون العلامة المائية عبارة عن نص كما بالصورة - أو تكون صورة كما في الصورة التالية مع تحياتي صاحب الملف منتصر الانسي تمت الاضافه 06/23/25 الاقسام قسم الأكسيس  

وعليكم السلام ورحمة الله تعالى وبركاته بعد إدن أستادنا الفاضل @Foksh جرب إفراغ اليوزرفورم من جميع الأكواد السابقة ولصق الكود التالي ربما يناسبك Private Sub UserForm_Initialize() ComboBox1.Clear: Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets: ComboBox1.AddItem sh.Name: Next ListBox1.ColumnCount = 3: ListBox1.ColumnWidths = "70;70;200" End Sub Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Dim ShName As String, Addr As String ShName = ListBox1.List(ListBox1.ListIndex, 0) Addr = ListBox1.List(ListBox1.ListIndex, 1) Sheets(ShName).Activate Sheets(ShName).Range("A4:F" & Sheets(ShName).Rows.Count).Interior.ColorIndex = xlNone With Sheets(ShName).Range("A" & Range(Addr).Row & ":F" & Range(Addr).Row) .Interior.Color = vbCyan: .Cells(1, 1).Activate End With TextBox2.Value = ListBox1.List(ListBox1.ListIndex, 2) End Sub Private Sub TextBox1_Change() On Error GoTo Cleanup SetApp False Dim ws As Worksheet, Sh_Name As String, ky As String, LastRow As Long, LastCol As Long Dim OnRng As Variant, i As Long, j As Long, xCount As Long, CellAddress As String Sh_Name = ComboBox1.Value ky = Trim(TextBox1.Text) If Sh_Name = "" Or ky = "" Then ListBox1.Clear Label5.Caption = "عدد النتائج: 0" If Sh_Name <> "" Then Sheets(Sh_Name).Range("A4:F" & _ Sheets(Sh_Name).Rows.Count).Interior.ColorIndex = xlNone Me.TextBox2 = "" GoTo Cleanup End If Set ws = Sheets(Sh_Name) With ws LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row LastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column End With ListBox1.Clear ws.Range("A4:F" & ws.Rows.Count).Interior.ColorIndex = xlNone xCount = 0 OnRng = ws.Range(ws.Cells(4, 1), ws.Cells(LastRow, LastCol)).Value For i = 1 To UBound(OnRng, 1) For j = 1 To UBound(OnRng, 2) If InStr(1, OnRng(i, j), ky, vbTextCompare) > 0 Then xCount = xCount + 1 CellAddress = ws.Cells(i + 3, j).Address(False, False) ListBox1.AddItem Sh_Name ListBox1.List(ListBox1.ListCount - 1, 1) = CellAddress ListBox1.List(ListBox1.ListCount - 1, 2) = OnRng(i, j) ws.Range("A" & (i + 3) & ":F" & (i + 3)).Interior.Color = vbCyan Exit For End If Next j Next i Label5.Caption = "عدد النتائج: " & xCount Cleanup: SetApp True End Sub Private Sub UserForm_Terminate() Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets sh.Range("A4:F" & sh.Rows.Count).Interior.ColorIndex = xlNone Next End Sub Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = "": ListBox1.Clear End Sub Private Sub ComboBox1_Change() On Error Resume Next If ComboBox1.ListIndex = -1 Then Exit Sub TextBox1 = "": ListBox1.Clear Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets sh.Range("A4:F" & sh.Rows.Count).Interior.ColorIndex = xlNone Next Sheets(ComboBox1.Value).Activate End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub ملاحظة :تم الاستغناء عن الكود Search_In_Sh() فأنت الآن لست بحاجة إليه بحث في عدة أوراق مع التحديد v2.xlsm

كذلك يمكن عند طباعة أصل ونسختين إضافة كلمة صورة للنسختين

وعليكم السلام ورحمة الله وبركاته .. كفكرة بسيطة ، جرب تعديل هذا الحدث :- Private Sub ListBox1_Click() Sheets(ListBox1.Column(0)).Activate Range(ListBox1.Column(1)).EntireRow.Select TextBox2.Value = ListBox1.Column(2) End Sub الى التعديل التالي :- Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Sheets(ListBox1.Column(0)).Activate Cells.Interior.Pattern = xlNone With Range(ListBox1.Column(1)) .Interior.Color = vbYellow .Activate End With TextBox2.Value = ListBox1.Column(2) End Sub قمت باختيار اللون الأصفر كمثال ، ولك الحرية بالتعديل على مزاجك

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

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

اعرض الملف إستخدام أزرار الأسهم للتنقل في النماذج المستمرة كما في أكسل {سلسلة الأدوات المساعدة المخصصة} بعد سنوات طويلة من العمل ببرنامج الأكسس أصبح لدي مخزون ضخم من التطبيقات والأكواد التي إستفدت منها الكثير علمياً وعملياً خلال هذه السنوات وعندما كنت احتاج لتعلم طريقة عمل جزئية معينة كنت ألاقي صعوبة في إيجادها كحل مستقل بذاتة بل تكون إما ضمن برنامج متكامل فيصبح فصلها عن بقية مكونات البرنامج أكثر صعوبة أو أجد لها مثال ولكن قد يكون أقل أو أكثر من المطلوب بكثير والمشكلة أن أغلب تلك الحلول تكون في مواقع أجنبية بعد كل هذا أصبح لدي مجموعة من الأدوات التي غالبا مأستخدمها في تطبيقاتي منها ماهو من تطوير أشخاص آخرين بدون أن أقوم بأي تعديل عليها ومنها ماقمت تعديلها بالإضافة أو الحذف ومنها ماهو من تطويري أنا وقررت مشاركتها معكم رداً للجميل لهذا المنتدى وليكون مصدرا لمستخدمي أكسس من العرب سواء لحل مشكلة يواجهونها أو للتعرف على إمكانيات البرنامج التي قد لايكونون على علم بها لهذا قمت بإنشاء هذه السلسلة بإسم {سلسلة الأدوات المساعدة المخصصة} أقوم فيها برفع أداه تقوم بحل جزئية محددة بحيث يمكن لأي شخص الإستفادة منها في تطبيقاته بسهولة حتى ولم تكن له أي دراية بالأكواد مجرد نسخ ولصق وحاولت جاهداً إرفاق كل أداة بشرح يوضح طريقة عملها وطريقة الإستفادة منها نبدأ بإذن الله بأداة بسيطة تقوم بجعل التنقل خلال عناصر التحكم في النماذج المستمرة بإستخدام مفاتيح الأسهم شبيها للتنقل في ورقة أكسل وستجدون في المرفق نموذج يوضح طريقة عمل الأداة وطريقة الإستفادة منها في تطبيقاتك إن شاء الله يستفيد منها الجميع صاحب الملف منتصر الانسي تمت الاضافه 06/22/25 الاقسام قسم الأكسيس  

الفكرة ليست في إيجاد بدائل فقط ، الفكرة في إيجاد بدائل دائمة وليس مؤقته ..

شكرا استاذ @Foksh الاجابة قبل الاخيرة صحيحة

لنجرب هذا مع إظافة الترتيب الأبجدي لعناصر الـكومبوبوكس عند النقر المزدوج يتم ترتيب القائمة تلقائيا قبل العرض Option Explicit Dim WS As Worksheet Dim OnRng As Variant Dim ColArr As Long Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set WS = Sheets("داتا") Dim f As Worksheet: Set f = Sheets("Sheet1") Dim lastRow As Long, cnt As Boolean, i As Long cnt = False lastRow = f.Cells(f.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow If Trim(f.Cells(i, "A").Value) <> "" Then cnt = True Exit For End If Next i 'A' إظهار القوائم لغاية أخر صف يتضمن تاريخ على عمود' If cnt Then If Target.Count = 1 And Not Intersect(Target, Range("C2:O" & lastRow)) Is Nothing Then ' OR ' C2:O100 تحديد اخر صف لإظهار القوائم يدويا بما يناسبك ' If Target.Count = 1 And Not Intersect(Target, Range("C2:O100")) Is Nothing Then ColArr = Target.Column If xColumn(ColArr) Then On Error Resume Next OnRng = WS.Range(WS.Cells(2, ColArr), _ WS.Cells(WS.Rows.Count, ColArr).End(xlUp)).Value On Error GoTo 0 If Not IsEmpty(OnRng) Then If Not IsArray(OnRng) Then ReDim OnRng(1 To 1, 1 To 1) OnRng(1, 1) = WS.Cells(2, ColArr).Value End If Me.ComboBox1.List = Application.Transpose(OnRng) Else Me.ComboBox1.List = Array() End If With Me.ComboBox1 .Height = Target.Height + 3 .Width = Target.Width .Top = Target.Top .Left = Target.Left .Value = Target.Value .Visible = True .Activate End With Else Me.ComboBox1.Visible = False End If Else Me.ComboBox1.Visible = False End If Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_Change() Dim d1 As Object Dim tmp As String Dim i As Long Set d1 = CreateObject("Scripting.Dictionary") If Me.ComboBox1.Value = "" Then Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.DropDown Else tmp = UCase(Me.ComboBox1.Value) & "*" For i = 1 To UBound(OnRng, 1) If UCase(Trim(OnRng(i, 1))) Like tmp Then d1(Trim(OnRng(i, 1))) = "" End If Next i If d1.Count > 0 Then Me.ComboBox1.List = d1.Keys Me.ComboBox1.DropDown Else Me.ComboBox1.List = Array(Me.ComboBox1.Value) Me.ComboBox1.DropDown End If End If ActiveCell.Value = Me.ComboBox1.Value End Sub Private Sub ComboBox1_Click() Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Function xColumn(colNum As Long) As Boolean Select Case colNum Case 3, 4, 5, 9, 10, 11, 15 xColumn = True Case Else xColumn = False End Select End Function Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ActiveCell.Offset(1).Select End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) On Error Resume Next Dim listArr() As String, i As Long If Not IsEmpty(OnRng) Then ReDim listArr(1 To UBound(OnRng, 1)) For i = 1 To UBound(OnRng, 1) listArr(i) = OnRng(i, 1) Next i Call filtre(listArr) Me.ComboBox1.List = listArr End If Me.ComboBox1.Value = "" Me.ComboBox1.Activate Me.ComboBox1.DropDown On Error GoTo 0 End Sub Private Sub filtre(arr() As String) Dim i As Long, j As Long, temp As String, n As Long n = UBound(arr) For i = 1 To n - 1 For j = i + 1 To n If StrComp(arr(i), arr(j), vbTextCompare) > 0 Then temp = arr(i): arr(i) = arr(j): arr(j) = temp End If Next j Next i End Sub تعديل 4 .xlsb

وعليكم السلام ورحمة الله تعالى وبركاته أخي @sabah19672025 أعتقد أن طلبك غير واضح نوعا ما يمكن تنفيذ ذلك بعدة طرق حسب طريقة عملك واحتياجك ونحتاج فقط لتحديد الطريقة التي تفضل استخدامها: هل اختيار الملفات يدويا أي يتم عرض نافذة لتحديد ملفات PDF التي تريد نقلها (واحد أو أكثر) وسيقوم الكود تلقائيا بـإنشاء مجلد بنفس اسم كل ملف و نقل الملف إلى داخل هذا المجلد أم البحث داخل مجلد معين بحيث يتم تحديد مجلد يحتوي على الملفات المعنية و البحث داخله تلقائيا عن كل ملفات PDF مع إنشاء مجلد بنفس اسم كل ملف و نقل كل ملف إلى المجلد المناسب دفعة واحدة عموما إليك عدة إحتمالات يمكن إختيار ما يناسبك منها Sub test_MovePDF() Dim dl As FileDialog, selectedItems As Variant, fso As Object, i As Integer Dim xPath As String, xName As String, xFolder As String, newFolder As String Set dl = Application.FileDialog(msoFileDialogFilePicker) With dl .AllowMultiSelect = True .Title = "اختر ملفات PDF" .Filters.Clear .Filters.Add "PDF Files", "*.pdf" If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملفات", vbExclamation Exit Sub End If Set fso = CreateObject("Scripting.FileSystemObject") For i = 1 To .selectedItems.Count xPath = .selectedItems(i) xName = fso.GetFileName(xPath) xFolder = fso.GetParentFolderName(xPath) newFolder = xFolder & "\" & Left(xName, Len(xName) - 4) If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & "\" & xName Next i End With MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub '=================================== Sub Move_Selected_PDFs_To_Folders() Dim fso As Object, fd As FileDialog Dim i As Long Dim xPath As String, fileName As String, xFolder As String, newFolder As String Dim baseName As String Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "اختر ملفات PDF المتفرقة" .Filters.Clear .Filters.Add "PDF Files", "*.pdf" .AllowMultiSelect = True If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملفات", vbExclamation Exit Sub End If Set fso = CreateObject("Scripting.FileSystemObject") For i = 1 To .selectedItems.Count xPath = .selectedItems(i) fileName = fso.GetFileName(xPath) xFolder = fso.GetParentFolderName(xPath) baseName = fso.GetBaseName(fileName) newFolder = xFolder & Application.PathSeparator & baseName If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & Application.PathSeparator & fileName Next i End With MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub '========================================= Sub test_Move_allPDF() Dim fso As Object, file As Object, newFolder As String Dim xFolder As String, xName As String, xPath As String With Application.FileDialog(msoFileDialogFolderPicker) .Title = "اختر المجلد الذي يحتوي على ملفات PDF" If .Show <> -1 Then Exit Sub xFolder = .selectedItems(1) End With Set fso = CreateObject("Scripting.FileSystemObject") For Each file In fso.GetFolder(xFolder).Files If LCase(fso.GetExtensionName(file.Name)) = "pdf" Then xName = fso.Getn(file.Name) xPath = file.Path newFolder = xFolder & Application.PathSeparator & xName If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & Application.PathSeparator & file.Name End If Next file MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub تحويل الى ملفات v2.xlsm

تفضل أخي ضع الكود التالي في حدث ورقة Sheet1 Option Explicit Dim OnRng As Variant Dim Cnt As Long Dim CrWS As Worksheet Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim dict As Object, lastRow As Long, i As Long, val As String, key As Variant, a As Variant On Error GoTo SupApp If Target.CountLarge > 1 Or Target.Row < 2 Or _ Target.Row > 100 Then ' '<==== هنا قم بتعديل اخر صف لاظهار القوائم بما يناسبك ComboBox1.Visible = False Exit Sub End If If ComboBox1 Is Nothing Then Exit Sub Set CrWS = ThisWorkbook.Sheets("داتا") If CrWS Is Nothing Then Exit Sub Cnt = Target.Column Select Case Cnt Case 3, 4, 5, 9, 10, 11, 15 lastRow = CrWS.Cells(CrWS.Rows.Count, Cnt).End(xlUp).Row If lastRow < 2 Then ComboBox1.Visible = False Exit Sub End If a = CrWS.Range(CrWS.Cells(2, Cnt), CrWS.Cells(lastRow, Cnt)).Value Set dict = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) val = Trim(CStr(a(i, 1))) If val <> "" Then If Not dict.Exists(val) Then dict.Add val, Nothing End If End If Next i If dict.Count > 0 Then ReDim OnRng(1 To dict.Count, 1 To 1) i = 1 For Each key In dict.Keys OnRng(i, 1) = key i = i + 1 Next key Else ReDim OnRng(1 To 1, 1 To 1) OnRng(1, 1) = "" End If With ComboBox1 .List = Application.Transpose(OnRng) .Height = Target.Height + 3 .Width = Target.Width .Top = Target.Top .Left = Target.Left .Value = Target.Value .Visible = True .Activate End With Case Else ComboBox1.Visible = False End Select Exit Sub SupApp: ComboBox1.Visible = False End Sub Private Sub ComboBox1_Change() On Error Resume Next If Me.ComboBox1.Value <> "" Then Dim d1 As Object, i As Long Set d1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(OnRng, 1) If InStr(1, UCase(OnRng(i, 1)), UCase(Me.ComboBox1.Value), vbTextCompare) > 0 Then d1(OnRng(i, 1)) = "" End If Next i If d1.Count > 0 Then Me.ComboBox1.List = d1.Keys Me.ComboBox1.DropDown End If End If ActiveCell.Value = Me.ComboBox1.Value End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then ActiveCell.Offset(1).Select ComboBox1.Visible = False KeyCode = 0 ElseIf KeyCode = vbKeyEscape Then ComboBox1.Visible = False KeyCode = 0 End If End Sub Private Sub ComboBox1_Click() On Error Resume Next If CrWS Is Nothing Then Exit Sub Dim lastRow As Long, xRng As Variant lastRow = CrWS.Cells(CrWS.Rows.Count, Cnt).End(xlUp).Row If lastRow < 2 Then Exit Sub xRng = CrWS.Range(CrWS.Cells(2, Cnt), CrWS.Cells(lastRow, Cnt)).Value If Not IsArray(xRng) Then ReDim tmp(1 To 1, 1 To 1) tmp(1, 1) = xRng xRng = tmp End If Me.ComboBox1.List = Application.Transpose(xRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub تعديل .xlsm

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

الكود الذي عملنا عليه سابقا يقوم بتحويل الأرقام إلى عربية أو إنجليزية لكن يتم ذلك عن طريق تغيير محتوى الخلية مباشرة وهذا يؤدي إلى فقدان أي صيغة كانت موجودة في الخلية للأسف الإكسيل لا يدعم تغيير عرض الأرقام من إنجليزية إلى عربية أو العكس داخل نفس الخلية بدون التأثير على محتواها بمعنى: لا يمكنك تحويل الأرقام داخل الخلية إلى العربية دون تعديل المحتوى نفسه مجرد اقتراح قد يكون مناسبا لتنفيذ طلبك مع الحفاظ على الصيغ: يمكن إظهار الأرقام العربية بصريا فقط وذلك عبر إضافة شكل شفاف (Textbox) فوق الخلية بهذا الأسلوب تبقى الصيغ تعمل كما هي والخلية الأصلية لا تتغير لاكن يمكنك محاكاة المظهر العربي للأرقام بصريا فقط دون التأثير على الصيغ أو البيانات كما في المثال التالي تحويل الورقة بالكامل الى لغة عربية دون تغير لغة الجهاز -v4.xlsb

استاذنك ان الخلية لو ناتجة من معادلة (بها )معادلة يكون فيه تغيير الى اللغة العربية والعكس بحيث يتم التغيير سواء خلية او مربع نص كذلك الاحتفاظ بجميع المعادلات والتنسيقات الاخرى كرقم او صيغة تاريخ

أقرت المملكة العربية السعودية منذ أيام قليلة رمزاً جديداً للريال السعودي، في هذا المقطع 3 طرق تشرح كتابة رمز الريال السعودي وإدراجه في برنامج اكسل، سواء إدراجه كصورة أو كحرف (رمز) من لوحة المفاتيح.

السلام عليكم ورحمة الله وبركاته يمكنكم تحميل الفونت الخاص برمز الريال السعودي الجديد المرفق بعد فك الضغط عنه وتثبيته؛ يمكنكم استخدامه بنجاح عن طريق إدراج رمز ؛ وهذا بعد تجربة ناجحة معي على اوفيس 2010. رمز الريال السعودي الجديد.rar

وعليكم السلام ورحمة الله تعالى وبركاته إدا كنت قد فهمت طلبك بشكل صحيح فربما هدا سيوفي بالغرض Option Explicit Dim WS As Worksheet Dim OnRng As Variant Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set WS = Sheets("Sheet1") If Not Intersect([A2:A11], Target) Is Nothing And Target.Count = 1 Then OnRng = WS.Range("C2:C" & WS.Cells(WS.Rows.Count, "C").End(xlUp).Row).value Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Height = Target.Height + 3 Me.ComboBox1.Width = Target.Width Me.ComboBox1.Top = Target.Top Me.ComboBox1.Left = Target.Left Me.ComboBox1.value = Target.value Me.ComboBox1.Visible = True Me.ComboBox1.Activate Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_Change() If Me.ComboBox1.value <> "" Then Dim d1 As Object Set d1 = CreateObject("Scripting.Dictionary") Dim tmp As String tmp = UCase(Me.ComboBox1.value) & "*" Dim i As Long For i = 1 To UBound(OnRng, 1) If UCase(OnRng(i, 1)) Like tmp Then d1(OnRng(i, 1)) = "" Next i Me.ComboBox1.List = d1.Keys Me.ComboBox1.DropDown End If ActiveCell.value = Me.ComboBox1.value End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ActiveCell.Offset(1).Select End If End Sub قائمة منسدلة مع البحث والاكمال التلقائي.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد إدن الأستاد @عبدالله بشير عبدالله تفضل جرب هدا بدون الحاجة لتغيير أسماء أوراق العمل Option Explicit Sub test() Dim Sh As Worksheet, WS As Worksheet: Set WS = Worksheets("واردالمنطقة") Dim iRow As Long, Rng As Range, dstRng As Long, lastRow As Long, Cnt As String, Updated As Boolean Dim tmp As String, j As Boolean, cell As Range, WSname As String, ky As String, n As String Cnt = "=SUBTOTAL(103,INDIRECT(ADDRESS(ROW(),COLUMN()+1)&"" :""&ADDRESS(ROW($E$7),COLUMN()+1)))" Updated = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> WS.Name Then WSname = Sh.Name: ky = Replace(WSname, "ال", "") For iRow = 7 To WS.Range("R" & WS.Rows.Count).End(xlUp).Row n = WS.Cells(iRow, "R").Value If InStr(1, n, ky, vbTextCompare) > 0 And n <> "" Then tmp = WS.Cells(iRow, "E").Value j = False For Each cell In Sh.Range("E7:E" & Sh.Rows.Count) If cell.Value = tmp Then j = True Exit For End If Next cell If Not j Then Set Rng = WS.Range(WS.Cells(iRow, 2), WS.Cells(iRow, 28)) dstRng = Sh.Cells(Sh.Rows.Count, "E").End(xlUp).Row + 1 If dstRng < 7 Then dstRng = 7 Sh.Cells(dstRng, "B").Resize(, 27).Value = Rng.Value Sh.Cells(dstRng, "D").Value = Date lastRow = Sh.Cells(Sh.Rows.Count, "B").End(xlUp).Row Sh.Cells(lastRow, "B").Formula = Cnt Updated = True End If End If Next iRow End If Next Sh MsgBox IIf(Updated, "تم ترحيل البيانات بنجاح", "جميع البيانات محدثة مسبقا"), vbInformation, "تعليمات" Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub ترحيل الصفوف مع عدم التكرار بتحقق شرط v2.rar

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

رقم 15 هو يوم بداية الاسبوع كما جاء في طلبك اليك المرفق التالي ربما تتضح اليك الفكرة لتساعدك على تحديد الرقم المناسب لك او قم بكتابة تاريخ من اختيارك في الخلية A2 مثلا وجرب استخدام شيئ كهدا Sub TEST() Dim d As Integer d = InputBox("المرجوا ادخال رقم بداية الاسبوع ") Range("C2").Formula = "=weeknum(a2," & d & ")" End Sub '******************************* Sub TEST2() Dim week As Date 'خلية التاريخ week = Range("a2") 'هنا تم تحديد يوم الجمعة كاول يوم في الاسبوع d = 15 st = Application.WeekNum(week, d) MsgBox "رقم الاسبوع هو :" & " " & st, vbInformation End Sub بالتوفيق .... WEEKDAY.xlsx

الاخ الكريم "ابو الشرف" آسف للتاخير كنت مشغولا كثيرا لكني استطعت التعديل على ملفك و اضفت الصور الى الاسماء و اليك المرفق sales rep sc food non food.rar

السلام عليكم ورحمة الله وبركاته ،، أرجو أن تتقبلوا هذه المساهمة المتواضعة وهي عبارة عن فائدة عملية ؛ لاستخراج مجموع عدة أرقام بمجرد تحديد الخلايا التي تحتوي الأرقام ، طبعا بدون دالة وبدون أي كود ؛ وهي خدمة ذاتية في الإكسل . شاهد المرفق تحياتي _________________.rar

عدد وتقوم مقامها الدالة COUNTA .. تقوم بحساب جميع الخلايا الغير فارغة .. سواء كانت تحتوي على أرقام أو حروف أو غيرها. أما عدد الأرقام والتي تقوم مقامها الدالة COUNT .. فهي تقوم بحساب عدد الخلايا التي تحتوي على أرقام فقط. جرى التعديل المطلوب على الكود .. شاهد المرفق، ____________________________________.rar

فقط لإثراء هذا الموضوع .. شاهد المرفق، ____________________________________.rar