محمد هشام.

اخي الفاضل المرجوا تصحيح بعض الاخطاء في اسماء الخلايا المرحلة والتي قد تمت الاشارة اليها في الملف مع التحقق من الارقام هل هي مطابقة ام لا تفاديا لاعادة العمل على الملف مرة اخرى السيارات(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

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

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

تفضل اخي https://streamable.com/dqdtjq

السلام عليكم ورحمة الله تعالى وبركاته .. اليك الاجابة والافادة معا . مع تعديل برنامجك ليتناسب مع طلبك . Private Sub Add_Click() '''''اضافة البيانات الى الليست بوكس''''' Dim MH As Variant, n As Byte If txtName.Value = Empty Then MsgBox "Please Enter Name": txtName.SetFocus: Exit Sub If txtJob.Value = Empty Then MsgBox "Please Enter Job": txtJob.SetFocus: Exit Sub If txtSallary.Value = Empty Then MsgBox "Please Enter Sallary": txtSallary.SetFocus: Exit Sub MH = Array(txtName.Value, txtJob.Value, txtSallary.Value, txtDate.Value) lstStItems.ColumnCount = 3 If lstStItems.ListCount <= 0 Then lstStItems.Column = MH Else lstStItems.AddItem MH(0) For n = 1 To 3 lstStItems.List(lstStItems.ListCount - 1, n) = MH(n) Next n End If txtName.Value = "" txtJob.Value = "" txtSallary.Value = "" End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Fill_Click() '''''ترحيل البيانات من الليست بوكس الى التيكست بوكس''''' If lstStItems.ListIndex <> -1 Then With lstStItems txtName.Value = .List(.ListIndex, 0) txtJob.Value = .List(.ListIndex, 1) txtSallary.Value = .List(.ListIndex, 2) End With Else MsgBox " !المرجوا تحديد الصف ", vbCritical, "" End If End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Update_Click() '''''تعديل البيانات على الليست بوكس''''' If lstStItems.ListIndex <> -1 Then With lstStItems .List(.ListIndex, 0) = txtName.Value .List(.ListIndex, 1) = txtJob.Value .List(.ListIndex, 2) = txtSallary.Value End With Else MsgBox "!المرجوا تحديد الصف المراد تعديله ", vbCritical, "" End If End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Delete_Click() If lstStItems.ListIndex = -1 Then '''''حدف البيانات من الليست بوكس''''' MsgBox "!المرجوا تحديد الصف المراد حدفه !", vbCritical, "" Exit Sub End If If lstStItems.ListIndex >= 0 Then cevap = MsgBox("?هل انت متاكد من حدف البيانات", vbYesNo) If cevap = vbYes Then lstStItems.RemoveItem lstStItems.ListIndex End If End If End Sub Enter Data_MH.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ...تفضل اخي Sub creation_onglets_MH() Dim contenu As String Dim lig As Long, MH As Long Dim ws As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next For Each ws In Worksheets If ws.Name <> "data" Then ws.Delete Next ws With Sheets("data") MH = .Range("E" & Rows.Count).End(xlUp).Row For lig = 4 To MH contenu = .Cells(lig, 5).Value If contenu = "" Then GoTo Suite If FeuilleExiste(ThisWorkbook, contenu) Then .Rows(lig).Copy Sheets(contenu).Range("A" & Rows.Count).End(xlUp).Offset(1, 0) Else Sheets.Add ActiveSheet.Name = contenu .Rows(1).Copy Sheets(contenu).Range("A3") .Rows(lig).Copy Sheets(contenu).Range("A4") With .Range("A:E") .HorizontalAlignment = xlCenter Range("a:a").ColumnWidth = 5 Range("b:b").ColumnWidth = 28.71 Range("c:c,d:d").ColumnWidth = 10 Range("E:E").ColumnWidth = 13 Dim i For i = 4 To 100 If ws.Name <> "data" Then Rows(i).RowHeight = 33 End If Next i End With End If Suite: Next lig Sheets("data").Activate NbSheet = ActiveWorkbook.Sheets.Count Range([A3], [IV3].End(xlToLeft)).Select Set MaPlage = Selection [A1].Select For NS = 1 To NbSheet Set Destination = ActiveWorkbook.Sheets(NS).Range("A3") MaPlage.Copy Destination Next NS Sheets("data").Move Before:=Sheets(1) Application.DisplayAlerts = True Application.ScreenUpdating = True End With End Sub Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean On Error Resume Next FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing) End Function move row_MH.xlsm