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

Sub MM() For G = 4 To 10 If Cells(G, 15) < 30 Then If Cells(G, 9).Value > Range("G1").Value Then 'Cells(G, 2).Interior.ColorIndex = 40 'Cells(G, 3).Interior.ColorIndex = 42 'Cells(G, 9).Interior.ColorIndex = 40 MsgBox ("ÇáãæÙÝ : " & " " & Cells(G, 2) & " " & "¡ íäÊåí ÇáÅÔÊÑÇß ÈÊÇÑíÎ : " & " " & Cells(G, 9) & " " & "¡ æÈÇÞí ãä ÇáÃíÇã : " & Cells(G, 15) & " " & "íæã ") 'Cells(G, 2).Interior.ColorIndex = xlNone 'Cells(G, 3).Interior.ColorIndex = xlNone 'Cells(G, 9).Interior.ColorIndex = xlNone End If End If Next End Sub

نعديل على النعديل Option Explicit Sub SUPER_ADV_FILTER() Application.ScreenUpdating = False Dim i%: i = 4 Dim y$, m%, K% Dim arr Dim MY_Sht As Worksheet Dim ws As Worksheet: Set ws = Sheets("Main") Dim rg As Object Dim rg_to_copy As Range Set rg_to_copy = ws.Range("a3").CurrentRegion Set rg = CreateObject("system.collections.arraylist") Dim lr%: lr = ws.Cells(Rows.Count, 1).End(3).Row With rg Do Until i > lr If Not .contains(CLng(ws.Range("d" & i).Value)) _ And ws.Range("d" & i).Value <> "" Then _ .Add CLng(ws.Range("d" & i).Value) i = i + 1 Loop .Sort For i = 0 To .Count On Error Resume Next y = CStr(.Item(i)) If Len(Sheets(y).Name) = 0 Then Sheets.Add after:=Sheets(Sheets.Count) ActiveSheet.Name = y End If On Error GoTo 0 Next End With Set rg = Nothing For i = 2 To Sheets.Count Sheets(i).Cells.Clear Sheets(i).Range("T1") = "رقم القيد" Sheets(i).Range("T2") = Sheets(i).Name rg_to_copy.AdvancedFilter 2, Sheets(i).Range("T1:T2"), Sheets(i).Range("A3") Sheets(i).Range("T1:T2") = vbNullString Next For Each MY_Sht In Sheets If MY_Sht.Name <> "Main" Then m = 4: K = 1 Do Until MY_Sht.Range("b" & m) = vbNullString MY_Sht.Range("A" & m) = K K = K + 1: m = m + 1 Loop End If Next Application.ScreenUpdating = True End Sub الملف من جديد tarhil_salim_Moreمطور.xlsm

السلام عليكم انسخ هذا الكود لحدث الورقة تعتمد تسمية الشيت النشط حسب قيمة خلية " A1 " بإمكانك تغير أي خليه تريد Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address = "$A$1" Then ActiveSheet.Name = Target.Text End Sub

اشكرك استاذ علي .... ونفع الله بك

وعليكم السلام تفضل TRANSFER.xlsm

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

أكمل بنفس نمط المعادلة في باقي المواد

تعديل الماكرو Option Explicit Sub SUPER_ADV_FILTER() Application.ScreenUpdating = False Dim i%: i = 4 Dim y$ Dim arr Dim ws As Worksheet: Set ws = Sheets("Main") Dim rg As Object Dim rg_to_copy As Range Set rg_to_copy = ws.Range("a3").CurrentRegion Set rg = CreateObject("system.collections.arraylist") Dim lr%: lr = ws.Cells(Rows.Count, 1).End(3).Row With rg Do Until i > lr If Not .contains(CLng(ws.Range("d" & i).Value)) _ And ws.Range("d" & i).Value <> "" Then _ .Add CLng(ws.Range("d" & i).Value) i = i + 1 Loop .Sort For i = 0 To .Count On Error Resume Next y = CStr(.Item(i)) If Len(Sheets(y).Name) = 0 Then Sheets.Add after:=Sheets(Sheets.Count) ActiveSheet.Name = y End If On Error GoTo 0 Next End With Set rg = Nothing For i = 2 To Sheets.Count Sheets(i).Cells.Clear Sheets(i).Range("T1") = "رقم القيد" Sheets(i).Range("T2") = Sheets(i).Name rg_to_copy.AdvancedFilter 2, Sheets(i).Range("T1:T2"), Sheets(i).Range("A3") Sheets(i).Range("T1:T2") = vbNullString Next Application.ScreenUpdating = True End Sub الملف tarhil_salim_مطور.xlsm

أحسنت استاذ سليم كود رائع جعله الله فى ميزان حسناتك

قم بتغيير اسم الورقة الاولى الى Main يجب ان يكون الجدول بشكل يغهمه الاكسل (لا أعمدة فارغة ) لذلك وضغت صفاً فارغاً بحيث يبدأ الحدول من الصف رقم 3 وجرب هذا الماكرو Option Explicit Sub SUPER_ADV_FILTER() Application.ScreenUpdating = False Dim i%: i = 4 Dim arr Dim ws As Worksheet: Set ws = Sheets("Main") Dim rg As Object Dim rg_to_copy As Range Set rg_to_copy = ws.Range("a3").CurrentRegion Set rg = CreateObject("system.collections.arraylist") With rg Do Until ws.Range("d" & i) = vbNullString If Not .contains(UCase(ws.Range("d" & i).Value)) _ Then .Add UCase(ws.Range("d" & i).Value) i = i + 1 Loop For i = 0 To .Count - 1 On Error Resume Next If Len(Sheets(.Item(i)).Name) = 0 Then Sheets.Add after:=Sheets(Sheets.Count) ActiveSheet.Name = .Item(i) End If On Error GoTo 0 Next End With Set rg = Nothing For i = 2 To Sheets.Count Sheets(i).Range("T1") = "رقم القيد" Sheets(i).Range("T2") = Sheets(i).Name rg_to_copy.AdvancedFilter 2, Sheets(i).Range("T1:T2"), Sheets(i).Range("A3") Sheets(i).Range("T1:T2") = vbNullString Next Application.ScreenUpdating = True End Sub الملف مرفق tarhil_salim.xlsm

طريقة الأخ عبد الرحمن هاشم صحيحة مئة بالمئة. وثمة طريقة تختصر الأمر قليلاً: في خانة البحث ضع ما هو أدناه (كما يبدو من اليمين إلى اليسار): \[(^2)\] في خانة الاستبدال ضع ما هو أدناه (كما يبدو من اليمين إلى اليسار): (\1) اضغط على "المزيد" واختر "باستخدام أحرف البدل". ثمّ قم بـ"استبدال الكل".

بالرغم من مرور وقت كبير على المشاركة إلا أنني وددت بمشاركة حل قد يساهم - على قدر فهمي بالوورد- بالمطلوب بعد تشغيل البحث Ctrl+F .. واختيار وضع الاستبدال نضع في أول خانة في البحث عن: [^f] ثم نضع في خانة استبدال بـ: (^&) وتضغط استبدال الكل.. وستجد المتن والحاشية قد أخذوا شكل ([الرقم]) ثم تشغل البحث مرة أخرى وتكتب فقط في البحث عن [ وتترك الاستبدال فارغ ثم تضغط استبدال الكل وهكذا مع جانب القوس ] أتمنى أن تفي بالغرض هذه الطريقة

السلام عليكم كل عام وانتم بخير هدية الشهر الكريم فورم بحث و تصفية بامكانية التعديل مرن لكل المستخدمين لا عليك سوى التعديل في كود اظهار الفورم ضع نطاق رؤوس الاعمدة و يصبح جاهز للاستخدام ' اسم نطاق رؤوس الاعمدة ' او عنوان النطاق ملحوق باسم الورقة Private Const MyTopColmnRng As String = "البيانات!$B$3:$L$3" المرفق 2003 2007 فورم بحث بامكانية التصفية.rar ودمتم في حفظ الله ============================================================== ملحوظة: في المشاركات ادناه وجدت ان السؤال الاكثر حول كيفية البحث ليشمل نتائج اوسع والحل موجود اصلا وهو استخدام النجمة وعلامة الاستفهام وقد اوجدت زرين لهذا الغرض أحرف البدل يمكن استخدام أحرف البدل التالية كمعايير مقارنة لعوامل التصفية وعند البحث عن محتوى واستبداله. * (علامة نجمية) أي عدد من الأحرف على سبيل المثال، يتم العثور على "شمال شرق" و"جنوب شرق" عند كتابة *شرق ؟ (علامة استفهام) أي حرف مفرد على سبيل المثال، يتم العثور على "سمير" و"سفير" عند كتابة س؟ير ============================================================== ايضا الذي تطلع عنده رسالة بالخطأ عند السطر .ColumnWidths = wColmn يقوم بحذف هذا السطر من الكود او يعمل شرطة احادية قبل السطر ليلغي قراءة هذا السطر وستنتهي المشكلة ان شاء الله لان هذا السطر يقوم بوضع مقاسات الاعمدة من النطاق يعني هو مش مؤثر في الكود اصلا ستبقى المقاسات الافتراضية للست ==============================================================

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

أخى الفاضل جرب هذا الكود show_calc.rar

السلام عليكم تفضل اخي الحاسبة.rar

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

قمت باضافة الكود الى ملف الأخ ابو اكرم كما قمت بعمل تعديل فى كوده لتثبيت مسار ملف قاعدة البيانات الى d:\temp2\Replacements.mdb حتى ال يسأل عنها فى كل ملف و الآن قم بما يلي أعد تسمية قاعدة البيانات باسمReplacements و ضعها فى نفس المسار مع الملفات التي تريد التجربة عليها أي d:\temp2 و شغل الكود ProcessAll فى الملف المرفق كما هو Replace.rar

اخوي طارق في حدث on key press اكتب الكود التالي مع تغير "firstName" في الكود الى اسم التيكست بوكس الموجود عندك اما الكلمه " First " هذي غيرها باسم الحقل الموجود في الجدول Dim strMatchText As String Dim strFoundText As String Select Case KeyAscii Case Is < 32: Exit Sub Case Is > 126: Exit Sub End Select strMatchText = Mid(Me.Firstname.Text, 1, Me.Firstname.SelStart) & Chr$(KeyAscii) KeyAscii = 0 If Len(strMatchText) = 0 Then Exit Sub With Me.RecordsetClone .FindFirst _ "First Like " & _ Chr(34) & _ Replace(strMatchText, """", """""") & _ "*" & Chr(34) If .NoMatch Then With Me.Firstname.Text = strMatchText & Right(.Text, Len(.Text) - (.SelStart + .SelLength)) .SelStart = Len(strMatchText) End With Else strFoundText = !First With Me.Firstname .Text = strFoundText .SelStart = Len(strMatchText) .SelLength = Len(strFoundText) End With End If End With End Sub