سليم حاصبيا

بسرعة الاعجاب + أفضل جواب

تم تعديل الكود ليتناسب مع ما تريد Option Explicit Sub My_Sum_New_With_Empty() Dim i%, s#, j%, m%, k% k = Cells(1, Columns.Count).End(1).Column - 2 Range(Cells(2, k + 1), Cells(1, k + 1).End(4)).ClearContents Range(Cells(2, 1), Cells(1, k).End(4)).Interior.ColorIndex = xlNone i = 2 Do Until Range("A" & i) = vbNullString For j = 2 To k If Cells(i, j) = "" Or _ Not IsNumeric(Cells(i, j)) Or _ Cells(i, j) = 0 Then GoTo Next_J s = s + Cells(i, j) m = m + 1 Cells(i, j).Interior.ColorIndex = 6 If m = Cells(i, k + 2) Then Exit For Next_J: Next Cells(i, k + 1) = s: s = 0: m = 0 i = i + 1 Loop End Sub الملفق من جديد Matlob_2_with_empty .xlsm

كيف يمكنك ان تجمع اسم موظف او اي نص مع رقم مثلاً على ماذا تحصل اذا كتبت هذه الممعادلة (سامي + 15+ محمد +25) تطوير بسيط للكود كي يلون ما تم جمعه Option Explicit Sub my_sum_New_with_color() Dim i%, s#, j%, m%, k% k = Cells(1, Columns.Count).End(1).Column - 2 Range(Cells(2, k + 1), Cells(1, k + 1).End(4)).ClearContents Range(Cells(2, 1), Cells(1, k).End(4)).Interior.ColorIndex = xlNone i = 2 Do Until Range("A" & i) = vbNullString For j = 2 To k If Cells(i, j) <> "" And Cells(i, j) <> 0 Then s = s + IIf(IsNumeric(Cells(i, j)), Cells(i, j), 0) m = m + 1 Cells(i, j).Interior.ColorIndex = 6 If m + 1 > Cells(i, k + 2) Then Exit For End If Next Cells(i, k + 1) = s: s = 0: m = 0 i = i + 1 Loop End Sub

الكود يقوم بهذا ايضاً لكن النتيجة تكون في العامود (ما قبل الاخير) العامود AP

الكود المطلوب لهذه الحالة Option Explicit Sub my_sum_New() Dim i%, s#, j%, m%, k% k = Cells(1, Columns.Count).End(1).Column - 2 Range(Cells(2, k + 1), Cells(1, k + 1).End(4)).ClearContents i = 2 Do Until Range("A" & i) = vbNullString For j = 2 To k If Cells(i, j) <> "" And Cells(i, j) <> 0 Then s = s + IIf(IsNumeric(Cells(i, j)), Cells(i, j), 0) m = m + 1 If m + 1 > Cells(i, k + 2) Then Exit For End If Next Cells(i, k + 1) = s: s = 0: m = 0 i = i + 1 Loop End Sub الملف مرفق Matlob_1.xlsm

ارفع مثالاً يحتوي عما تريد بالضبط (النتائج المتوقعة)

اخي لا حاجة لتشغيل الماكرو من خلال حدث الصفحة (لان ذلك يخلق لك مشاكل) بعد التعديل على اسماء الشيتات كما كانت (في الماكرو وفي الـــ Tab ) وتحديد النصوص التي يجب كتابتها بدل ِAccept و Ref فقط حدد كل من (تم الرفض - تم الصرف) وانقر الزر مرة واحدة عبارتي (تم الرفض و تم الصرف) حاول وضعها في قوائم منسدلة تلافياً للأخطاء الاملائية او المسافات الناقصة او الزائدة في الكتابة) واذا وجدت نفسك مخطئاً في احد ما قم بتصليح الخطأ واضغط الزر مرة ثانية انا شخصياً لا أفضل تسمية الشيتات باللغة العربية مثلا صفحة الكفالات قم بتسميتها Kafalat

تفادياً لمشاكل اللغة العربية مع الكود وصعوبة نسخه (حيث تظهر أحرف غريبة وغير مفهومة) تم تغيير اسماء الصفحات التي يتعاطى معها الكود Option Explicit Sub get_data_advanced_filter() Dim Mursal As Worksheet: Set Mursal = Sheets("kaf_Mursal") Dim aceepted As Worksheet: Set aceepted = Sheets("kaf_accepted") Dim Refused As Worksheet: Set Refused = Sheets("kaf_Refused") Dim Rg_to_copy As Range: Set Rg_to_copy = Mursal.Range("c10").CurrentRegion With aceepted .Range("c10").CurrentRegion.ClearContents .Range("s1") = Mursal.Range("L10") .Range("s2") = "Accepted" Rg_to_copy.AdvancedFilter 2, .Range("s1:s2"), .Range("c10") .Range("s1:s2") = vbNullString End With With Refused .Range("c10").CurrentRegion.ClearContents .Range("s1") = Mursal.Range("L10") .Range("s2") = "Ref" Rg_to_copy.AdvancedFilter 2, .Range("s1:s2"), .Range("c10") .Range("s1:s2") = vbNullString End With End Sub الملف مرفق مع الكود و زر للنتفيذ yatim.xlsm

مطلوبك كان هذا (نسخة من السؤال) اضافة زر لتبديل الصفحات على الشييت اليا دون الحاجة النزول الى الاسفل الورقة لما اضاعة وقت المعلمين والاساتذة بامور غير المطلوبة

رائع استاذ علي ومعادلات رائعة ايضاً لكن اسمح لي ان اضيف كود لهذا الغرض لعل فيه افادة لمن يريد التعمق اكثر في عالم الــ Diuctionary من خلال الــــ VBA Option Explicit Sub Get_Phone() Rem ====>> Created By Salim Hasbaya On 18/7/2019 Application.ScreenUpdating = False Dim Dict As Object Dim Salim As Worksheet Dim Itm, K, i%: i = 2 Dim My_Arr, M_key Set Dict = CreateObject("Scripting.Dictionary") Set Salim = Sheets("Salim") With Salim .Range("D2").CurrentRegion.Offset(1) _ .Resize(, 10).ClearContents i = 2 Do Until .Range("A" & i) = vbNullString K = .Range("A" & i): Itm = .Range("B" & i) If Not Dict.Exists(K) Then Dict.Add K, Itm Else Dict(K) = Dict(K) & ";" & Itm End If i = i + 1 Loop '======================================== i = 2 With Dict For Each M_key In .keys Range("D" & i) = M_key My_Arr = Split(.Item(M_key), ";") If UBound(My_Arr) = 0 Then Range("E" & i) = .Item(M_key) Else Range("E" & i).Resize(, UBound(My_Arr)) = My_Arr End If i = i + 1 Next End With '======================== .Range("D2").CurrentRegion.Value = _ .Range("D2").CurrentRegion.Value End With Dict.RemoveAll: Set Dict = Nothing Salim.Columns("E:H").AutoFit Application.ScreenUpdating = True End Sub الملف مرفق FIND_PHONE.xlsm

تم اضافة زر الى كل من الصفحة الثانية و الثالثة لان الصفحة الاولى محمية لا يمكن اضافة زر اليها Emploi_salim.xlsm

اعتذر عن تقديم المساعدة مع شيت مقفل بواسطة كلمة سر لكن يمكن ادراج هذا الكود في موديل مستقل ووضع له زر في كل شيت Option Explicit Sub Select_My_sheet() Dim act_sh As Worksheet: Set act_sh = ActiveSheet Dim goto_sh As Worksheet Dim t% t = act_sh.Index Select Case t Case Sheets.Count Set goto_sh = Sheets(1) Case Else Set goto_sh = Sheets(t + 1) End Select goto_sh.Select End Sub

اين الاعجاب

يا سيدي المعادلات لا ترى الا محتوى الخلية ولا تنظر ابداً الى تنسيقها او لون الخط فيها او اي شيء في مظهرها الخارجي لذلك بانتظار ان تقوم شركة المايكروسوفت بابتكار هكذا معادلات لا يمكننا الا الاستعانة بالاكواد بالنسبة لمعايير الجمع الكود يقوم بذلك ويدرج لك اوتوماتيكياً عدد الخلايا الملونة

تم معالجة الامر بتعديل معادلة التنسيق الى COUNTIF(B$3:B$102,B3)>1= ( لاحظ علامة الـــ $ فقط امام الحرف B الاول والثاني ) و التنسيق في النطاق من الخلية B3 الى الخلية AO102 cond_format.xlsx

بالنسبة للقسم الاول من السؤال تم معالجة الامر ( الصفحة Salim من هذا الملف) (لا حاجة لادخال كل يوم بيومه من الشهر (يكفي كتابة رقم الشهر والسنة واكسل يقوم بالباقي) بالنسبة للأسئلة الباقية يرجى التوضيح اكثر مع اعطاء أمثلة واقعية Salery.xlsx

جرب هذا الماكرو Option Explicit Sub my_sum() Dim Main_Rg As Range, Cel As Range Dim All_Rows%, i%, s#, t% Set Main_Rg = Range("a3", Range("a2").End(4)).Resize(, 14) All_Rows = Main_Rg.Rows.Count i = 1 Do Until i = All_Rows + 1 For Each Cel In Main_Rg.Rows(i).Cells If Cel.Interior.ColorIndex <> xlNone Then t = t + 1 s = s + IIf(IsNumeric(Cel), Cel, 0) End If Next Cel Cells(i + 2, 17) = t: t = 0 Cells(i + 2, 15) = s: s = 0 i = i + 1 Loop End Sub الملف مرفق matloub.xlsm

حيث ان الدالة () SUM تتجاهل النصوص و تعتبرها صفر لذلك يمكن استعمال هذه المعادلة بكل بساطة =SUM(B4:C4)/2

استبدل الى هذا الماكرو الذي يجد لك كلمة انتهى في اي عامود كانت و يقوم باخفاء الصفوف بعدها Sub hide_rows() Dim my_rg As Range Dim Copy_Rg As Range Dim find_Rg As Range Dim St$: St = "انتهى" Dim R%, Ro%, x%, Y% Dim t As Boolean show_all Application.ScreenUpdating = False ARCHIVE.Range("D2").CurrentRegion.Offset(1).Clear Set my_rg = Main.Range("D3").CurrentRegion For Y = 1 To my_rg.Columns.Count t = Not (IsError(Application.Match(St, my_rg.Columns(Y), 0))) If t Then Exit For End If Next Y If Not (t) Then GoTo LEAVE_ME_OUT x = my_rg.Rows.Count Set find_Rg = my_rg.Columns(Y).Find(St, after:=my_rg.Columns(Y).Cells(x)) If Not find_Rg Is Nothing Then R = find_Rg.Row: Ro = R Do If Copy_Rg Is Nothing Then Set Copy_Rg = Main.Range("b" & R).Resize(, 10) Else Set Copy_Rg = Union(Copy_Rg, Main.Range("b" & R).Resize(, 10)) End If Set find_Rg = my_rg.FindNext(find_Rg) R = find_Rg.Row If Ro = R Then Exit Do Loop Copy_Rg.Copy ARCHIVE.Range("b2") Copy_Rg.EntireRow.Hidden = True ARCHIVE.Columns("b:k").AutoFit End If '+++++++++++++++++++++++++++++++++++++++++++++++ ARCHIVE.Range("b2").CurrentRegion.Sort _ key1:=ARCHIVE.Range("h2"), Header:=1 '++++++++++++++++++++++++++++++++++++++++++++++++ LEAVE_ME_OUT: Set my_rg = Nothing: Set find_Rg = Nothing Set Copy_Rg = Nothing Application.ScreenUpdating = True End Sub '============================================ Sub show_all() Application.ScreenUpdating = False Main.Rows.Hidden = False Application.ScreenUpdating = True End Sub الملف مرفق SAlim_2.xlsm

تم التعديل على الكود Option Explicit Function ColorFunction(rColor As Range, rRange As Range, Optional SUM As Boolean) Application.Volatile Dim rCell As Range, lCol# lCol = rColor.Interior.ColorIndex ColorFunction = 0 For Each rCell In rRange If rCell.Interior.ColorIndex = lCol Then _ ColorFunction = _ ColorFunction + IIf(SUM, Application.SUM(rCell), 1) Next rCell End Function

UDF رائعة اخي علي لكن اليس هناك من مجال لاختصارها دون الحاجة الى (vResult) لتبدو بهذا الشكل Option Explicit Function ColorFunction(rColor As Range, rRange As Range, Optional SUM As Boolean) Dim rCell As Range, lCol# lCol = rColor.Interior.ColorIndex ColorFunction = 0 For Each rCell In rRange If rCell.Interior.ColorIndex = lCol Then _ ColorFunction = _ ColorFunction + IIf(SUM, Application.SUM(rCell), 1) Next rCell End Function

و ما هو امتداد الملف الذي تريد رفعه الامتداد هو ما بعد النقطة في اسم الملف اسم الملف Find_first_cell_in Row .xlsm الامتداد هو xlsm اسم لم يكن اسم الامتداد في لائحة الرسالة لا يمكن رفع الملف

قم يتصوير الرسالة وارفع الصورة

اين الملف

جرب هذا الماكرو Option Explicit Rem =====>> created by Salim Hasbaya 13/7/2019 Sub Get_Data_Please() '========================== Dim Source_Sh As Worksheet Dim Target_Sh As Worksheet Dim LRS%, LRT%, RG_S As Range, RG_T As Range Dim cel As Range, My_adrs As Range '========================== Set Source_Sh = Sheets("DATA") Set Target_Sh = Sheets("TAB") LRS = Source_Sh.Cells(Rows.Count, 2).End(3).Row LRT = Target_Sh.Cells(Rows.Count, 3).End(3).Row Set RG_S = Source_Sh.Range("b3:M" & LRS) Set RG_T = Target_Sh.Range("C4:E" & LRT) Target_Sh.Range("F4:H" & LRT).ClearContents On Error Resume Next For Each cel In RG_T On Error Resume Next Set My_adrs = RG_S.Find(cel, lookat:=1) On Error GoTo 0 If Not My_adrs Is Nothing Then cel.Offset(, 3) = Source_Sh.Cells(My_adrs.Row, 2) End If Next End Sub الملف مرفق ب جدول - Copy.xlsm