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

انتبه من فضلك وأرجو ان يكون الأمر واضح لأننا نبهنا كثير جداً على هذا الموضوع .. ان لا تنتظر المساعدة من أحد بدون رفع ملف مدعوم بشرح كافى عن المطلوب فلا يمكن العمل من خلال صورة كما انه لا يمكن العمل على التخمين , وتجنباً لإهدار وقت كل من يطلع على مشاركتك دون جدوى أو أهمية مثلى أنا الن !!!!

تفضل اخي 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

تفضل اخي اليك طلبك 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

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

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

وعليكم السلام بالنسيبة للحالة الاولى ضع الكود التالي في مصدر بيانات الكمية المخزنية بالمناسبة ..لايحبذ استخدام اللغة العربية حتى لا تحصل لخبطة في الاكواد جرب النتيجة ..والله كريم على النقطة الثانية =IIf(IsNull([اسم الصنف]);"";DLookUp("[الموجود في المخزن]";"الموجود في المخزن";"[المعرف] = " & [اسم الصنف].[Column](0)))

مع ان الكلام موجه لاخي وصديقي المهندس قاسم نعم ممكن تعديل بسيط على عمل اخي قاسم ولو املك الوقت لقدمت حل بفكره اخرى تغير لون الزر(2)(1).accdb

احسنت اخي قاسم ويمكن التصريح باسم العنصر مباشرة او كما يفعل بعض جيل الطيبين بوضع قيمة العنصر بدون كتابة اسمه acAttachment 126 Attachment control acBoundObjectFrame 108 BoundObjectFrame control acCheckBox 106 CheckBox control acComboBox 111 ComboBox control acCommandButton 104 CommandButton control acCustomControl 119 ActiveX control acEmptyCell 127 EmptyCell control acImage 103 Image control acLabel 100 Label control acLine 102 Line control acListBox 110 ListBox control acNavigationButton 130 NavigationButton control acNavigationControl 129 NavigationControl control acObjectFrame 114 Unbound ObjectFrame control acOptionButton 105 OptionButton control acOptionGroup 107 OptionGroup control acPage 124 Page control acPageBreak 118 PageBreak control acRectangle 101 Rectangle control acSubForm 112 SubForm control acTabCtl 123 Tab control acTextBox 109 TextBox control acToggleButton 122 ToggleButton control acWebBrowser 128 WebBrowserControl control تحياتي

محمد عفيفى اليك الملف بعد التعديل يتضمن كود تحديد 10 صفوف بداية من الخلية النشطة والى اسفلها وكود لتحديد صف الخانة العاشرة بداية من الخلية النشطة والى اسفلها لنطاق معين يمكنك تعديله من داخل الكود. وكود لتحديد عمود الخانة العاشرة بداية من الخلية النشطة اوفيسنا-test3.xlsm

لا حاجة لعدد من الزرار يساوي عدد الشيتات الكود Option Explicit Sub get_Eleves_Names(ByVal my_SHEET As String) Rem ====>>>> Created By Salim Hasbaya On 27/6/2019 '================================ Dim y%, SH As Worksheet Dim ss%: ss = 0 For y = 1 To Sheets.Count If Sheets(y).Name Like "*#*" Then ss = ss + 1 End If Next '============================ Dim m As Worksheet: Set m = Sheets("Main") Dim Fst As Worksheet: Set Fst = Sheets(my_SHEET) Dim Ar(4), Ar_Fasl(1 To 9) Dim t: t = Sheets(my_SHEET).Index Dim lrA%: lrA = m.Cells(Rows.Count, "A").End(3).Row Dim lrF%: lrF = m.Cells(Rows.Count, "F").End(3).Row Dim mal$: mal = "ذكر" Dim fem$: fem = "انثى" Dim i% Dim Start_row_B%: Start_row_B = 10 Dim Start_row_H%: Start_row_H = 10 Fst.Range("b10").Resize(500, 11).ClearContents With m For i = 2 To lrA Ar(0) = .Cells(i, "H"): Ar(1) = "" Ar(2) = .Cells(i, "G"): Ar(3) = .Cells(i, "A") Ar(4) = .Cells(i, "C") If .Range("B" & i) = mal Then Fst.Cells(Start_row_B, "B").Resize(, UBound(Ar) + 1) = Ar Start_row_B = Start_row_B + 1 ElseIf .Range("B" & i) = fem Then Fst.Cells(Start_row_H, "H").Resize(, UBound(Ar) + 1) = Ar Start_row_H = Start_row_H + 1 End If Next For i = 4 To 12 Ar_Fasl(i - 3) = CStr(Fst.Cells(5, i)) Next Fst.Range("c10").Resize(Start_row_B - 10) = _ Application.Transpose(Ar_Fasl(t - 1)) Fst.Range("I10").Resize(Start_row_H - 10) = _ Application.Transpose(Ar_Fasl(t - 1)) Fst.Range("K1") = ss End With Set m = Nothing: Set Fst = Nothing Erase Ar: Erase Ar_Fasl End Sub '================================================== Sub EXTACCT_NAME() Dim Impt Dim x% Impt = InputBox("Please Give_me the sheet's name to transfer data" & _ Chr(10) & "Write the sheet's name Without Cotes") If Impt = "Main" Then MsgBox "I can't Change the values of Principal Sheet" Exit Sub End If On Error Resume Next x = Len(Sheets(Impt).Name) If x = 0 Then On Error GoTo 0 MsgBox "The Sheet: " & Impt & " Not Existes" Exit Sub End If Call get_Eleves_Names(Impt) End Sub يكفي زر واحد و الماكرو يطلب منك اسم الشيت التي تريد الترحيل اليها مثل هذه الصورة(كتابة اسم الشيت بدون الأقواس) الملف مرفق للمعاينة وابداء الرأي Mes_Eleves_new.xlsm