محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ..اولا اسف على التاخير بسبب ظروف العمل .. السيارات(1).xlsm

اخي سعد لقد تمت تجربة الملف اكثر من مرة ليس به اي مشكلة 🤔

وعليكم السلام ورحمة الله تعالى وبركاته اخي الفاضل الملف يشتغل معي بدون مشاكل يمكنك المشاهدة من الرابط ادناه https://streamable.com/8b3ws8 حاول اخي تحميل الملف من المرفقات

وعليكم السلام ورحمة الله تعالى وبركاته هناك عدة طرق منها اختيار خانة معينة مثال لنفترض ان اسم الماكرو هو (Macro3) سيتم اعادة التشغيل للماكرو بشرط القيمة الموجودة في الخلية A1 Sub test1() Dim i As Long For i = 1 To Range("A1").Value Macro3 Next i End Sub كما يمكنك ادخال عدد التكرار يدويا بهده الطريقة Sub test2() Dim i As Long Dim N As Variant N = InputBox("اختر عدد مرات التكرار") If Not IsNumeric(N) Then Exit Sub For i = 1 To N Macro3 Next i End Sub اليك ملف للتجربة test_macro.xlsm

صراحة طلبك غير مفهوم اولا: مادا تعني لك بوكس ؟ ثانيا :هل تقصد فلترة العمود مباشرة على الاسم او تحديد الاسم في العمود ام ماذا ؟

اخي الفاضل المرجوا تصحيح بعض الاخطاء في اسماء الخلايا المرحلة والتي قد تمت الاشارة اليها في الملف مع التحقق من الارقام هل هي مطابقة ام لا تفاديا لاعادة العمل على الملف مرة اخرى السيارات(1).xlsm

تفضل اخي Sub FindLastRow_N°5() Dim LastRow As Long With ActiveSheet LastRow = .Cells(.Rows.Count, "M").End(xlUp) If .Cells(.Rows.Count, "M").End(xlUp).Value = 5 Then UserForm2.Show Else Exit Sub End If End With End Sub فرز تعديل - Copy.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ضع هده المعادلة في الخلية : (D8) لاستخراج الاسماء بدون تكرار =SIERREUR(SI(A2<>"";INDEX($A$2:$A$200;EQUIV(0;NB.SI($D$7:D7;$A$2:$A$200);0));"");"") وهده في الخلية (E8) للحصول على ارقام الصفحات مع سحب المعادلات للأسفل =JOINDRE.TEXTE("- "; VRAI; SI(SIERREUR(EQUIV(B2:B500; SI(D8=A2:A500; B2:B500; ""); 0); "")=EQUIV(LIGNE(A2:A500); LIGNE(A2:A500)); B2:B500; "")) f.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي Sub cherche() Dim plage As Range, add As Range Dim X As Long, Y As Long Dim cellule As Variant Set plage = Range("E8:E1000") Set cellule = Range("k4") ActiveSheet.ListObjects("الجدول1").Range.AutoFilter Field:=1, Criteria1:=Feuil1.Range("k4").Value Set SearchRange = Range("E8:E1000") Set Findrow = SearchRange.Find(cellule, LookIn:=xlValues, lookat:=xlWhole) If Findrow Is Nothing Then MsgBox "الاسم غير موجود" Else X = Findrow.Row Y = Findrow.Column Cells(X, Y).Select End If End Sub ملاحظة قد تم استبدال قائمة الاسماء بقائمة مطاطية مع حدف التكرار أول خلية_MH.xlsb

تفضل اخي Sub Hany() Dim a As Long If Range("a1") = "" Then MsgBox "المرجوا ادخال البيانات" Else Application.ScreenUpdating = False a = ThisWorkbook.Sheets("Data").Range("a1000000").End(xlUp).Row a = a + 1 Feuil2.Select Feuil3.Cells(a, 1) = Range("b1") Feuil3.Cells(a, 2) = Range("a1") Feuil3.Cells(a, 3) = Range("b3") Feuil3.Cells(a, 4) = Range("b4") Feuil3.Cells(a, 6) = Range("b5") Feuil3.Cells(a, 7) = Range("b6") Feuil3.Cells(a, 8) = Range("b7") Feuil3.Cells(a, 10) = Range("b8") Feuil3.Cells(a, 11) = Range("b9") Feuil3.Cells(a, 12) = Range("b10") Range("b1") = "" Range("a1") = "" Application.ScreenUpdating = True End If End Sub تكلفة المخبوزات للحصول على الربح.xlsb

الف مبروك أستاذ حسونة مزيدا من التوفيق والعطاء بادن الله

يمكنك اخي فعل دالك بتعديل بسيط في هدا السطر c.Offset(0, -19).Value = Format(x, "0") قم باضافة رقم 1 بدل الصفر c.Offset(1, -19).Value = Format(x, "0")

اخي بالنسبة لحفظ الملف اجعل الكود بهده الطريقة مع انشاء فولدر على سطح المكتب باسم fatora ActiveWorkbook.SaveAs Filename:= _ "C:\Users\edb3\Desktop\fatora\" & MH & "-" & "فاتورة رقم" & ".xlsx", FileFormat:=51

تفضل اخي Sub Test() Dim c As Range, M2%, x% Dim derlig As Long derlig = Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row Range("a4:a1000").ClearContents M2 = Range("T" & Rows.Count).End(xlUp).Row For Each c In Range("T4:T" & M2) If c.Value = 1 Then x = x + 1 c.Offset(0, -19).Value = Format(x, "0") End If 'في حالة الرغبة باستبدال المعادلات في الصف الأول بالكود يمكنك تفعيل هده السطور 'Range("a1") = Application.Sum(Range("a4:a" & derlig)) 'Range("b1") = Application.Sum(Range("b4:b" & derlig)) 'Range("c1") = Application.Sum(Range("c4:c" & derlig)) 'Range("d1") = Application.Sum(Range("d4:d" & derlig)) 'Range("e1") = Application.Sum(Range("e4:e" & derlig)) 'Range("f1") = Application.Sum(Range("f4:f" & derlig)) 'Range("g1") = Application.Sum(Range("g4:g" & derlig)) 'Range("h1") = Application.Sum(Range("h4:h" & derlig)) 'Range("i1") = Application.Sum(Range("i4:i" & derlig)) 'Range("j1") = Application.Sum(Range("j4:j" & derlig)) 'Range("k1") = Application.Sum(Range("k4:k" & derlig)) 'Range("l1") = Application.Sum(Range("l4:l" & derlig)) 'Range("m1") = Application.Sum(Range("m4:m" & derlig)) 'Range("n1") = Application.Sum(Range("n4:n" & derlig)) 'Range("o1") = Application.Sum(Range("o4:o" & derlig)) 'Range("p1") = Application.Sum(Range("p4:p" & derlig)) 'Range("q1") = Application.Sum(Range("q4:q" & derlig)) 'Range("r1") = Application.Sum(Range("r4:r" & derlig)) Next End Sub فرز تعديل - MH.xlsm

تفضل اخي =IF($T4=1;1+MAX($A$3:$A3);"") فرز تعديل - Copy.xlsm

أخي كما سبق الذكر في المشاركة السابقة قد تم العمل فقط على مسألة إيجاد نفس القيمة وتلوينها بالنسبة للطلب الثاني صراحة لم أستوعب الفكرة لنفترض أنك كما جاء في الملف تبحث عن الرقم 260000 فهو موجود في 462499 كما ذكرت لاكن السؤال في حالة وجود الرقم 512499 فهو كذلك موجود بداخله ما هو العمل؟

اخي هناك فكرة قد تم تناولها مع احد الاخوة سابقا في احد المواضيع ربما تسهل عليك عملية التلوين بما ان الكلمات و الحروف مكررة يمكنك استخدام كود ينوب عنك في هده المسالة فقط ادخل اوقم بنسخ الكلمة او الحرف المطلوب في الخلية (F2) بنفس الشكل المكتوب به مثال : ( فَبَشِّرْهُم) لا يمكن كتابتها (فبشرهم) وسوف يتم تلوين جميع الكلمات دفعة واحدة مع الاحتفاظ بالتنسيق ..كما يمكنك تعديل رقم اللون المطلوب داخل الكود للون المطلوب كما في الصورة تحت Sub ChangeColor2() 'البحث في عمود("a") Application.ScreenUpdating = False Dim Rng As Range Dim MH As String Dim MH2 As String Dim x As Long Dim m As Long Dim y As Long Dim xFNum As Integer Dim xArrFnd As Variant Dim xStr As String MH = Range("F2").Value If Len(MH) < 1 Then Exit Sub xArrFnd = Split(MH, ",") ''' قم بتحديد النطاق المطلوب '''''' Range("A1:A100000").Select For Each Rng In Selection With Rng For xFNum = 0 To UBound(xArrFnd) xStr = xArrFnd(xFNum) y = Len(xStr) m = UBound(Split(Rng.Value, xStr)) If m > 0 Then MH2 = "" For x = 0 To m - 1 MH2 = MH2 & Split(Rng.Value, xStr)(x) '3= اللون الاحمر 'قم باستبدال الرقم 3 برقم اللون المطلوب .Characters(Start:=Len(MH2) + 1, Length:=y).Font.ColorIndex = 3 MH2 = MH2 & xStr Next End If Next xFNum End With Next Rng Range("F2").Select Application.ScreenUpdating = True End Sub قائمة الالوان اختر اللون المناسب وقم باستبداله داخل الكود في حالة تعدر عليك الامر يمكنك رفع الملف للتعديل فسوف نكون سعداء بمساعدتك في هدا العمل الطيب (فخِدْمَةَ الْقُرْآنِ مِنْ خَيْرِ الْأَعْمَالِ وَأَشْرَفِهَا، وَأَعْظَمِ الْقُرُبَاتِ وَأَعْلَاهَا، فَهُوَ خَيْرُ دَارٍ، وَحَسَنَاتٌ جَارِيَةٌ لِصَاحِبِهِ، حَيًّا وَمَيِّتًا.) ووفقنا الله واياكم اخي لما يحب ويرضى 4.xlsm

اخي لم تجب عن سؤال الاستاد hassona229 ... وهو ما هي الطريقة المستخدمة لتبديل الوان الحروف !!!!!!! . قد قمت باستبدالها يدويا بدون ادنى مشكلة والنتيجة كما في الصورة

تفضل اخي اليك طلبك Sub ChangeColor2() 'البحث في عمود("E") Application.ScreenUpdating = False Dim Rng As Range Dim MH As String Dim MH2 As String Dim x As Long Dim m As Long Dim y As Long Dim xFNum As Integer Dim xArrFnd As Variant Dim xStr As String MH = Range("F2").Value If Len(MH) < 1 Then Exit Sub xArrFnd = Split(MH, ",") Range("E1:E100000").Select For Each Rng In Selection With Rng For xFNum = 0 To UBound(xArrFnd) xStr = xArrFnd(xFNum) y = Len(xStr) m = UBound(Split(Rng.Value, xStr)) If m > 0 Then MH2 = "" For x = 0 To m - 1 MH2 = MH2 & Split(Rng.Value, xStr)(x) .Characters(Start:=Len(MH2) + 1, Length:=y).Font.ColorIndex = 3 MH2 = MH2 & xStr Next End If Next xFNum End With Next Rng Range("F2").Select Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''' 'البحث في عمود a,b Sub ChangeColor() Set MR = Range("A1:B10000") For Each cell In MR If cell.Value = Range("F2") Then cell.Interior.ColorIndex = 6 End If Next End Sub MH.xlsm

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

هذا سؤال آخر ليس له علاقة بطلبك الأول أخي وغير واضح!!!!

1- البحث عن طريق ادخال قيمة البحث في خلية معينة. 2- عند العثور على القيمة يذهب المؤشر الى الخليه التي فيها القيمة وتلوينها باللون الاصفر أخي قد تمت الاجابة بناءا على طلبك هذا !!!!! أما بالنسبة للمتسلسلة قد تم تجربتها هي كذلك . يتم تلوين محتوى الخلية بالكامل ربما أخي تقصد تلوين أرقام معينة داخل الخلية لأنك واضع المتسلسل (257500- 262449) في خانة واحدة...؟؟؟؟؟

وعليكم السلام ورحمة الله تعالى وبركاته نفضل اخي Private Sub CommandButton2_Click() Dim wbNew As Workbook Dim MH As String, ws As Worksheet Dim val As String Dim shape As Excel.shape MH = CStr(Sheets("الفاتورة").Range("B1")) val = Worksheets("الفاتورة").Range("a14") Application.ScreenUpdating = False Application.DisplayAlerts = False Sheets("الفاتورة").Select Worksheets("الفاتورة").Copy Set wbNew = ActiveWorkbook With Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("a3").Select End With For Each shape In ActiveSheet.Shapes shape.Delete Next Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents Range("A14").Value = val ActiveWorkbook.SaveAs Filename:= _ "C:\Users\edb3\Desktop\" & MH & "-" & "فاتورة رقم" & ".xlsx", FileFormat:=51 ActiveWorkbook.Close Sheets("الفاتورة").Activate Range("b1").Value = Range("b1").Value + 1 Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents Range("a14").Formula = "=NumtoTxt(R[-1]C[6],""جنيهاً"",""قرشاً"")" Range("a3").Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Private Sub CommandButton3_Click() Range("b1").Value = Range("b1").Value + 1 Application.Dialogs(xlDialogPrinterSetup).Show ThisWorkbook.Sheets("الفاتورة").PrintOut copies:=1 Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents End Sub حفظ فاتورة.xlsm

تفضل اخي الكريم خلية البحث (G3) 'البحث في عمود A,B Sub ChangeColor() Set MR = Range("A1:B10000") For Each cell In MR If cell.Value = Range("g3") Then cell.Interior.ColorIndex = 6 End If Next End Sub ''''''''''''''''''''''''''''''''''''''''' ' E,البحث عن القيمة في متسلسلة عمود 'وتغيير لون الكتابة Sub FindLoop() Dim strFirstAddress As String Dim rngFindValue As Range Dim rngSearch As Range Dim rngFind As Range Set rngFind = ActiveSheet.Range("E1:E100000") Set rngSearch = rngFind.Cells(rngFind.Cells.Count) Set rngFindValue = rngFind.Find(Range("g3"), rngSearch, xlValues) If Not rngFindValue Is Nothing Then strFirstAddress = rngFindValue.Address rngFindValue.Font.Color = vbRed Do Set rngFindValue = rngFind.FindNext(rngFindValue) rngFindValue.Font.Color = vbRed Loop Until rngFindValue.Address = strFirstAddress End If End Sub 298667823_.xlsm

السلام عليكم ورحمة الله تعالى وبركاته تفضل اخي يمكنك اختيار معيار الفلترة في خانة (D1) او ادخاله يدويا لفلترة جميع الاوراق على نفس المعيار Sub Filter_Me() Dim ans As String Dim T As ListObject MH = Sheets("Drawing").Range("D1") For i = 1 To Sheets.Count For Each T In Sheets(i).ListObjects T.Range.AutoFilter Field:=1, Criteria1:=MH Next Next End Sub ''''الغاء الفلترة من جميع الاوراق Sub Remove_Filters_From_Workbook() Dim MH As Worksheet Dim lstObj As ListObject For Each MH In Worksheets For Each lstObj In MH.ListObjects lstObj.AutoFilter.ShowAllData Next lstObj Next MH End Sub New Microsoft Excel Worksheet_MH.xlsm