محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي Sub copy() Dim MH As Worksheet, MH2 As Worksheet Dim c As Range, f As Range Dim rngCopy As Range, rngCopyTo Set MH = Sheet1 Set MH2 = ThisWorkbook.Sheets("Sheet2") Application.ScreenUpdating = False Feuil1.Activate Range("A2:A200,C2:C200,E2:E200,G2:G200,I2:I200,k2:k200,M2:M200,O2:O200,Q2:Q200,S2:S200").ClearContents For Each c In Application.Intersect(MH.UsedRange, MH.Rows(1)) If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then Set f = MH2.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _ LookAt:=xlWhole) If Not f Is Nothing Then Set rngCopy = MH.Range(c.Offset(1, 0), _ MH.Cells(Rows.Count, c.Column).End(xlUp)) Set rngCopyTo = MH2.Cells(Rows.Count, _ f.Column).End(xlUp).Offset(1, 0) rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value End If End If Next c Sheets("Sheet1").Activate Application.ScreenUpdating = True End Sub Exmple2.xlsm

اخي على ما يبدو لي انك لم تفهم الكود جيدا ركز معي هدا السطر يعني انه في حالة وجود فراغات في الخلايا يتم عدم تنفيد الكود مع اظهار رسالة تخبرك بملئ البيانات وهدا مستبعد ..الاصل في التعديل انك تقوم باستدعاء البيانات اولا اما برقم الكود او رقم الاقامة ثم تعديلها وفي هده الحالة تكون جميع الخلايا بها قيمة . تم وضع الشرط فقط لتجنب استبدال البيانات بالفراغ عند تنفيد الكود If Range("L10").Value = "" And Range("d10").Value = "" And Range("h10").Value = "" Then MsgBox "المرجوا ادخال البيانات" Exit Sub End If وعند التعديل لا نقوم بتغيير قيمة الخلايا L7 او D7 ..يتم التعديل مكان الاسهم كما في الصورة

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

تفضل اخي =MAX(IF((A3:A9>=$H$4)*(A3:A9<=$H$5),B3:B9,"")) tabl.xlsx

الحدف والتعديل يتم بشرط إضافة رقم الإقامة فقط . وهذا ما قمت بطلبه. في حالة الرغبة باضافة إمكانية حذف الصفوف والتعديل بشرط رقم الكود يمكنك ذالك بقراءة الاكواد لقد تم شرحها خطوة بخطوة وتنفيذ المطلوب بكل سهولة

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ..اولا اسف على التاخير بسبب ظروف العمل .. السيارات(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 الى حين توضيح المطلوب الثاني ..بالتوفيق