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

وعليكم السلام-تفضل EX&Income1..xlsm

السلام عليكم علي فرض أن البيانات موجودة بالعمود (A) جرب هذا الكود Sub Macro1() [A9999].End(xlUp).Offset(1, 0).Select Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select Selection.Rows.Delete Shift:=xlUp [B1].Select ActiveWorkbook.Save End Sub

تفضل الملف للاستاذ سليم المحترم لعله يكون طلبك Reel_date_to Combo.xlsm

تفضل Private Sub UserForm_Initialize() Dim rMonth As Long For rMonth = 1 To 12 Me.ComboBox1.AddItem Format(DateSerial(2020, rMonth, 1), "MMMM") Next rMonth End Sub monnth.xlsm

السلام عليكم ورحمة الله وبركاته بعد إذن الأخوة المشرفين أفادني أحد الأخوة بحل للملف وأن أضعه بين أيديكم للفائدة أيجاد-التاريخ.xlsm

تم ويعمل مائة بالمائة سلمت وسلمت يمينك وبارك الله لك وحفظك من كل شر يا باشا حضرتك عبقرى من عباقرة الاكسيل تسلم لنا وحفظك الله استاذى واخى فى الله استاذ سليم

شرح ازاي اقدر اعمل اخفاء وظهار لشريط التنقل NAVIGATION PANE عن طريق الكود وازي اقدر اعمل BUTTON يعمل اظهار لشريط التنقل واخفاء واظهاره عن طريق قايمة بFILE فى الاكسيس

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

القائمة المنسدلة في ُE2 وليس E3 خيث اللون الأصفر عندك

شكر وتقدير واحترام من اخيك

يجب استبدال الرفم 1 الذي هو رقم العامود " ِA " في هذا السطر الى رقم العامود M اي (13) او استبداله الى "M" ro = Sh.Cells(Rows.Count, "M").End(3).Row و كذلك هنا If .Cells(i, "M") <> vbNullString And _ Not col.Contains(.Cells(i, "M").Value) Then col.Add .Cells(i, "M").Value

جرب هذا الشيء Asd_2000.xlsx

في حدث عند تغيير التحديد Worksheet_SelectionChange ضع كود تغيير اللغة إذا كان رقم العمود الحالي كذا اجعل اللغة كذا Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 1 Then LoadKeyboardLayout "00000401", 1 'Arabic Else LoadKeyboardLayout "00000409", 1 'English End If End Sub مع إضافة كود دالة تغيير لغة لوحة المفاتيح في موديول منفصل #If Win64 Then Declare PtrSafe Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long Declare PtrSafe Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long #Else Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long #End If خالص دعواتي بالتوفيق

يفضل وضع الكود هنا حتى يسهل الاستفادة منه . جزيت خيرا

يجب تحرير السطر بهذا الشكل With .Range("E2:E50").Validation

تحفة حلو جدا استاذى والله ما اروعك بارك الله فيك لى سؤال حاولت اغير العمود من A الى m مكان القائمة من f2 الى ("e:e50") الكود لم يعمل خرجت من الشيت ورجعت ايضا لم يعمل اشكرك من كل قلبى استاذى الغالى لقلبى استاذ سليم

جرب هذا الملف Option Explicit Dim col As Object Dim ro%, i% Dim Sh As Worksheet '++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("a:a")) Is Nothing _ And Target.Count = 1 Then data_val Cells(2, "F") = Target End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++++++++++++++ Sub data_val() Set Sh = Sheets("Sheet1") ro = Sh.Cells(Rows.Count, 1).End(3).Row Set col = CreateObject("System.Collections.Arraylist") With Sh For i = 2 To ro If .Cells(i, 1) <> vbNullString And _ Not col.Contains(.Cells(i, 1).Value) Then col.Add .Cells(i, 1).Value End If Next i With .Cells(2, "F").Validation .Delete: .Add 3, Formula1:=Join(col.toarray, ",") End With End With End Sub الملف مرفق Abou_hasn_validation.xlsm

بالتوفيق اخي الكريم تحياتي

تفضل هناك كود من أعمل الأستاذ ياسر خليل والمعادلة من أعمال الأستاذ سليم حاصبيا , لهما منا كل الحب والإحترام Option Explicit Sub UniqueSortedList() Dim Arr, X As Object Application.ScreenUpdating = False With CreateObject("System.Collections.ArrayList") Set X = .Clone: X.Add " " Sheets("Sheet1").Activate For Each Arr In Sheets("Sheet1").Range("m2", Range("M" & Rows.Count).End(xlUp)).Value If Arr <> "" Then If IsNumeric(Arr) Then If Not .Contains(Arr) Then .Add Arr Else If Not X.Contains(Arr) Then X.Add CStr(Arr) End If End If Next .Sort: X.Sort: .addRange X: Arr = Join(.ToArray, ",") End With Sheets("Sheet1").Activate With Sheets("Sheet1").Range("e4").Validation .Delete .Add xlValidateList, 1, 1, Arr End With Application.ScreenUpdating = True End Sub على الرغم ان هذا الموضوع تم تناوله أكثر من مرة وكان عليك البحث جيداً -تفضل عمل قائمة منسدلة ديناميكية مطاطية بدون تكرار اى بند فيها قائمة منسدلة بدون تكرار وبدون فراغات بالكود والمعادلات.xlsm

شكرا لحضرتك مجهود كبير بارك الله فيك

دائماً مبدع جزاك الله خير الثواب

بعد اذن صديقي الرائد هذا الماكرو وزيادة في اثراء الموضوع (كود من سطر واحد) Option Explicit Private Sub UserForm_Initialize() Me.ComboBox1.List = _ Application.Transpose _ ([index(text(date(1,row(1:12),1),"[$-801]mmmm"),)]) End Sub أو اذا كنت تريده على الشيت Sub fill_combo() Sheets("sheet1").OLEObjects("My_Combo").Object.List = _ [index(text(date(1,row(1:12),1),"[$-801]mmmm"),)] End Sub الملف مرفق Month_series_For_Userform.xlsm

موضوع قيِّم للغاية، استفدت منه كثيراً، فألف شكر للسائل وللمجيب. وللإفادة، يمكن تحديد كل الجداول الموجودة ضمن المستند من خلال هذا الماكرو: Dim objDoc As Document Dim objTable As Table Application.ScreenUpdating = False 'Initialization Set objDoc = ActiveDocument 'Set each table in document as a range editable to everyone. With objDoc For Each objTable In .Tables objTable.Range.Editors.Add wdEditorEveryone Next objDoc.SelectAllEditableRanges wdEditorEveryone objDoc.DeleteAllEditableRanges wdEditorEveryone Application.ScreenUpdating = True End With

شكرا لكلماتك الطيبة ولا يخفى عليك إمكانية دمج الدالتين في دالة واحدة مع تمرير باراميتر ثالث يحدد النوع صفر أو يترك فارغا للحالة الأولى 1 أو أي رقم غير صفر للحالة الثانية Function kest(total As Double, start As Date, Optional ftype As Boolean = 0) As Double If ftype = 0 Then If Date >= DateAdd("m", 1, start) And Date <= DateAdd("m", 37, start) Then If Month(Date) - Month(start) = 1 Then kest = 550 * (total * 96.25 / 100 / 550 - Int(total * 96.25 / 100 / 550)) + total * 3.75 / 100 Else kest = (total - 550 * (total * 96.25 / 100 / 550 - Int(total * 96.25 / 100 / 550)) - total * 3.75 / 100) / 35 End If Else kest = 0 End If Else If Date >= DateAdd("m", 1, start) And Date <= DateAdd("m", 11, start) Then kest = total / 10 Else kest = 0 End If End If End Function وفقنا الله جميعا لكل خير

جرب هذا الملف Option Explicit Sub Get_Str() Dim My_Sheet As Worksheet Dim My_Regex As Object Dim K As Byte, La%, t%, st$ Set My_Sheet = Sheets("Sheet1") Set My_Regex = CreateObject("VBScript.RegExp") My_Regex.Global = True With My_Sheet La = .Cells(Rows.Count, 1).End(3).Row .Range("C2").CurrentRegion.ClearContents For K = 3 To 4 My_Regex.Pattern = _ IIf(K = 4, "[\u0621-\u064A]+", "\w+") For t = 1 To La If My_Regex.test(.Range("A" & t)) Then st = My_Regex.Replace(.Range("A" & t), "") .Cells(t, K) = Trim(st) End If Next t st = "" Next K End With Set My_Regex = Nothing End Sub الملف مرفق ReGex_Kaddour_1.xlsm

السلام عليكم تفضل جرب هذا تحديث الخلايا بنقرة واحدة.rar

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله استناداً إلى الموضوع في الرابط التالي من هنا قمت بتطوير كود بحيث يمنع التكرار في العمود الأول ، وفي نفس الوقت يسمح للنسخ لخلية واحدة فقط ، أما إذا تم النسخ لأكثر من خلية فإنه يتم التراجع عن الأمر ومسح الخلايا المنسوخة ها هو الكود يوضع في حدث ورقة العمل ، ويتم التعامل مع العمود الأول Private Sub Worksheet_Change(ByVal Target As Range) Dim Cl As Variant, Dat As Variant Dim DupCtr As Double Dim LastRow As Long If Not Application.Intersect(Target, Columns("A:A")) Is Nothing Then Application.EnableEvents = False If Target.Cells.Count > 1 Then Dat = Target.Formula For Each Cl In Dat If Cl <> "" Then MsgBox "Change Only One Cell At A Time", , "Too Many Changes!" Application.Undo: Application.CutCopyMode = False GoTo Skipper End If Next Cl End If '========================================================================= LastRow = Cells(Rows.Count, "A").End(xlUp).Row DupCtr = Application.WorksheetFunction.CountIf(Range(Cells(1, "A"), Cells(LastRow, "A")), Target.Text) If DupCtr > 1 Then MsgBox "You Have Entered A Duplicate" Target.ClearContents: Target.Activate GoTo Skipper End If End If Skipper: Application.EnableEvents = True End Sub أرجو أن يكون الموضوع مفيد لكم حمل الملف من هنا تقبلوا وافر تقديري واحترامي

السلام عليكم ورحمة الله وبركاته إخواني الأحباب في المنتدى الغالي هل فكرت يوماً ؟ إذاً أنت موجود .. لأن الحكمة بتقول : أنا أفكر إذاً أنا موجود ، وبتعديل بسيط ممكن نقول : أنا أؤمن بالله إذاً فالله موجود وأنا حي القلب قبل حياة الجسد سرحت اعذروني أقدم لكم اليوم كود جديد ، يقوم الكود كما هو موضح بالعنوان (والموضوع بيبان من عنوانه ..فمحدش يتوه مني عشان أنا متعمد أتوهكم) ..كما هو موضح يقوم الكود بتنفيذ الماكرو أو الإجراء الفرعي عدد معين من المرات ، يمكنك أن تحدد عدد المرات في الملف المرفق قمت بوضع عدد المرات في الخلية C3 ويمكن تغييره بالطبع ، كما يمكن أيضاً (عشان الناس متقولش إني بخلان عليكم بمعلومة) ممكن أن تغير في الكود لتضع عدد مرات التكرار الذي ترغبه داخل الكود ، وذلك من خلال تغيير هذا السطر nTimes = Range("C3").Value إلى هذا السطر nTimes = 3 إذاً فأنت حر في اختيارك لطريقة وضع قيمة المتغير المرتبط بعدد مرات التكرار وإليكم الكود بالشكل الكامل (والكمال لله وحده) 'تعريف المتغير الذي يمثل عداد لعدد مرات تنفيذ الماكرو Dim I As Integer Sub RunMacroNTimes() 'تعريف المتغير الذي يمثل عدد مرات تنفيذ الماكرو Dim nTimes As Integer 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'وضع القيمة صفر للعداد I = 0 '[C3] ليساوي قيمة الخلية [nTimes] تعيين قيمة للمتغير nTimes = Range("C3").Value 'حلقة تكرارية لتكرار تنفيذ الماكرو طبقاً لقيمة الخلية Do While I < nTimes 'زيادة قيمة العداد بمقدار واحد في كل حلقة تكرارية I = I + 1 'استدعاء الماكرو المراد تنفيذه Call Test 'الانتقال داخل الحلقة التكرارية إلى أن تساوي قيمة العداد قيمة الخلية Loop 'إظهار رسالة تفيد بعدد مرات تنفيذ الماكرو MsgBox "تم تنفيذ الماكرو " & I & " مرات" 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub Sub Test() MsgBox "مرحباً بكم إخواني .. الترحيب رقم " & I End Sub وعشان خاطر عيون حبايبي اللي زعلانين مني (وهما عارفين مين .. وكل لبيب بالإشارة يفهم .. ومش عايز حد يكون ساخـ (هـ) ـــر مني) قمت بشرح أسطر الكود للاستفادة منه في أكواد أخرى كما أقدم لكم ملف مرفق للإطلاع عليه (ودا عشان الناس الكسلانة .. شايف مختار بيحمل الملف المرفق .. لا إنت لا إنت طبقه بنفسك) وأخيراً تقبلوا تحياتي ودمتم في رعاية الله Run Macro Number Of Times YasserKhalil.rar

السلام عليكم ورحمة الله وبركاته إخواني الكرام في المنتدى الأغر معكم في موضوع جديد وشيق ومفيد ، مع عالم الإكسيل ومع كل جديد ، ومع تنشيط لخلايا المخ اللي تخلي مخك حديد .. أقدم لكم المزيد والمزيد ، لعل الجميع يستفيد ، ويستضاء بنا ولو من بعيد (شكلي سرحت ..أعتذر عن المقدمة الطويلة يا أبو عيد) معنا اليوم فورم بسيط (فيه صندوق الدنيا (صندوق نص) TextBox وزر أمر Command Button) بالنسبة لصندوق النص غيرت فيه من الخصائص حاجتين اتنين وبس .. خاصية اسمها MultiLine ودي خليتها True ودي عشان تقدر سعادتك تكتب في أكتر من سطر والخاصية التانية EnterKeyBehavior ودي بردو True ودي عشان تقدر بعد ما تكتب سطر تضغط Enter يقوم ايه ؟؟ يقوم ينتقل للسطر اللي بعديه .. وهكذا وهكذا يعني تكتب كلمة البحث المراد البحث عنها وتضغط إنتر ، وتقدر تكتب كلمة تانية وتضغط إنتر ، وتقدر تكتب كلمة تالتة وتضغط إنتر ، وتقدر تكتب كلمة ( - - - - - ) كتبتها بالحبر السري عشان محدش ياخد باله وتضغط إنتر وهكذا وهكذا ولما تدوس على زر الأمر Search هتلاقي النتائج المراد البحث عنها تم تلوينها جرب مثلاً اكتب Yasser واضغط إنتر ، واكتب في السطر اللي بعديه "ياسر" من غير أقواس تنصيص واضغط إنتر ، وأخيراً دوووووس على زر الأمر وشوف النتائج ودا شكل الكود الموضوع في زر الأمر Private Sub CommandButton1_Click() Dim Cell As Range, Keys, Key, I As Long If Me.TextBox1.Value = "" Then Exit Sub Sheets("Sheet1").Cells(1).CurrentRegion.Font.ColorIndex = xlAutomatic Keys = Split(TextBox1.Value, vbCrLf) For Each Cell In Sheets("Sheet1").Cells(1).CurrentRegion.Columns(1).Cells For Each Key In Keys I = InStr(1, Cell.Value, Key) If I > 0 Then Cell.Characters(I, Len(Key)).Font.Color = vbRed End If Next Key Next Cell End Sub أرجو أن يكون الملف مفيد للجميع .. تقبلوا تحياتي وهكذا وهكذا Multiple Search & Color Results.rar

كود عند تفعيل الماكرو يقوم بإضافة فى كل تفعيل شيت جديد Private Sub GenerateNewWorksheet() Dim ActSheet As Worksheet Dim NewSheet As Worksheet ' Prevents screen refreshing. Application.ScreenUpdating = False Set ActSheet = ActiveSheet Set NewSheet = ThisWorkbook.Sheets().Add() NewSheet.Move After:=Sheets(ThisWorkbook.Sheets().Count) ActSheet.Select ' Enables screen refreshing. Application.ScreenUpdating = True End Sub

تفضل اخي الكريم Private Sub Workbook_Open() Dim M, pasword pasword = "1234" If Date >= CDate("01/05/2014") Then M = MsgBox("ان كان لديك كلمة المرور فاضغط علي نعم", vbCritical + vbYesNo, "تأكيد") If M = vbNo Then Application.Quit Else If M = vbYes Then If pasword = InputBox("ادخل كلمة المرور هنا", "كلمة المرور") Then Sheet1.Select Exit Sub GoTo 1 Else MsgBox "ليس لديك الحق في فتح البرنامج", vbCritical, "خطأ" Application.Quit End If: End If: End If: End If 1 End Sub تقبل خالص تحياتي

الاخوة الكرام فكرة الملف تتلخص في انك لو كنت تعمل على ملف اكسل و تركته مفتوحا و غادرت المكان فان الكود بعد مدة سيغلق الملف و الجهاز يمكن تجربة الملف و لكن مع الحرص على حفظ اي عمل آخر على الجهاز غلف الجهاز بعد مدة من ترك ملف غير نشط.rar