سليم حاصبيا

امسح ما هو في المربعات الحمراء من الكود

هذا تلقائي Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("$C$2:$H$40", "$K$2:$O$40")) Is Nothing _ And Target.Count = 1 Then Auto_sum End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++++++++++++++++++++ Sub Auto_sum() Dim H% With Sheets("Sheet2") H = .Cells(Rows.Count, "H").End(3).Row With .Range("k2:k" & H) .Formula = _ "=IF(C2="""","""",IF(AND(C2<=0,D2>=0,F2<=0,G2<=0,H2<=-15,M2<=-13),""Sell"",""""))" .Value = .Value End With With .Range("L2:L" & H) .Formula = _ "=IF(C2="""","""",IF(AND(F2<=0,G2<=0,H2<=-15,M2<=-8),""Wait"",""Close""))" .Value = .Value End With With .Range("N2:N" & H) .Formula = _ "=IF(C2="""","""",IF(AND(F2>=0,G2>=0,H2>=15,M2>=8),""Wait"",""Close""))" .Value = .Value End With End With End Sub الملف من جديد Emad_1.xlsm

الكود المطلوب تم ازالة الالوان الفاقعة لسهولة النظر الى الملف (بمكنك اعادنها) أو نسخ الكود الى ملفك Option Explicit Sub Auto_sum() Dim H% With Sheets("Sheet2") H = .Cells(Rows.Count, "H").End(3).Row .Range("k2:k" & H).Formula = _ "=IF(AND(C2<=0,D2>=0,F2<=0,G2<=0,H2<=-15,M2<=-13),""Sell"","""")" .Range("k2:k" & H).Value = _ .Range("k2:k" & H).Value .Range("L2:L" & H).Formula = _ "=IF(AND(F3<=0,G3<=0,H3<=-15,M3<=-8),""Wait"",""Close"")" .Range("L2:L" & H).Value = _ .Range("L2:L" & H).Value .Range("N2:N" & H).Formula = _ "=IF(AND(F2>=0,G2>=0,H2>=15,M2>=8),""Wait"",""Close"")" .Range("N2:N" & H).Value = _ .Range("N2:N" & H).Value End With End Sub الملف مرفق Emad.xlsm

لا يمكن العمل بدون ملف مرفق فعلى ماذا تريد نجربة الماكرو؟؟؟؟ ثم لماذا لا تكتب الكود بشكل يمكن قرائته يسهولة مثلاً هذا الجزء منه For RowNum = 2 To 40 With Worksheets("Sheet2").Cells(RowNum, 3) If .Value <= 0 _ And .Offset(, 1) >= 0 _ And .Offset(, 3) <= 0 _ And .Offset(, 4) <= 0 _ And .Offset(, 5) <= -15 _ And .Offset(, 10) <= -13 Then .Offset(, 8) = "SELL" End If End With Next RowNum

التعديل

هذا الماكرو Private Sub Worksheet_Change(ByVal Target As Range) Dim My_rg As Range Dim Cret As Range Dim Rg_to As Range Const i = 2 Set My_rg = Range("B2:F13") Set Cret = Range("L3:L4") Set Rg_to = Range("J6:M6") Application.EnableEvents = False If Target.Address(0, 0) = "L4" _ And Target.Count = 1 Then My_rg.AdvancedFilter i, Cret, Rg_to End If Application.EnableEvents = True End Sub تم الشرح الماكرو بالتفصيل للتمكن من متابغتة مع امكانية احتصاره الى Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address(0, 0) = "L4" _ And Target.Count = 1 Then Range("B2:F13").AdvancedFilter 2, _ Range("L3:L4"), Range("J6:M6") End If Application.EnableEvents = True End Sub Bachiri.xlsm

اين هو هذا اضفت عمود اسمه رقم المستند

تم تعديل الكود ليعطي حصص كل استاذ منفرداً جسب الأيام والصف والتوقيت Option Explicit Sub find_Prof() Dim A, i%, X% Dim First_Address$, Current_Address$ Dim F_rg As Range Dim Optional_rg As Range Dim Plage_E As Range, Plage_F As Range Dim Plage_G As Range, Plage_H As Range Dim Plage_I As Range, Plage_Match As Range Dim Ak As Worksheet, Pr As Worksheet Dim Clas$ Set Ak = Sheets("Akssam") Set Pr = Sheets("Prof") Pr.Range("E8:I84").ClearContents A = Array("محمود", "علي", "مصطفى", "عمر", "نورة", "عدي", "زيد") For i = 0 To UBound(A) Set Plage_Match = Pr.Range("D8:D18").Offset(i * 11) Set Plage_E = Pr.Range("E8:E18").Offset(i * 11) Set Plage_F = Pr.Range("F8:F18").Offset(i * 11) Set Plage_G = Pr.Range("G8:G18").Offset(i * 11) Set Plage_H = Pr.Range("H8:H18").Offset(i * 11) Set Plage_I = Pr.Range("I8:I18").Offset(i * 11) Set F_rg = Ak.Range("D8:M29").Find(A(i), lookat:=1) If Not F_rg Is Nothing Then First_Address = F_rg.Address Current_Address = First_Address Do Select Case F_rg.Row Case Is <= 18: Clas = "4م1 ف1" Case Is <= 19: Clas = "4م1 ف2" End Select Select Case F_rg.Column Case 5: Set Optional_rg = Plage_E Case 7: Set Optional_rg = Plage_F Case 9: Set Optional_rg = Plage_G Case 11: Set Optional_rg = Plage_H Case 13: Set Optional_rg = Plage_I End Select X = Application.Match(Ak.Cells(F_rg.Row, 3), Plage_Match, 0) Optional_rg.Cells(X) = F_rg & " / " & F_rg.Offset(, -1) _ & ": " & Clas Set F_rg = Ak.Range("D8:M29").FindNext(F_rg) Current_Address = F_rg.Address If First_Address = Current_Address Then Exit Do Loop End If 'for F_rg Next i End Sub الملف مرفق (عسى ان ينال الإعجاب) allaoua_Super.xlsm

جرب هذا الكود 1-دائماً وأبداً تسمية الشيتات باللغة الأجنبية لحسن عمل الكود ونسخه ولصقه والابتعاد قدر الامكان عن الخلايا المدمجة Option Explicit Sub find_Prof() Dim A, itm Dim Ad1$, Ad2$ Dim F_rg As Range Dim Find_what Dim Ak As Worksheet, Pr As Worksheet Dim Clas$ Dim col Set Ak = Sheets("Akssam") Set Pr = Sheets("Prof") Pr.Range("E8:I29").ClearContents A = Array("محمود", "علي", "عمر", "مصطفى") For Each itm In A Set F_rg = Ak.Range("D8:M29").Find(itm, lookat:=1) If Not F_rg Is Nothing Then Ad1 = F_rg.Address: Ad2 = Ad1 Do Select Case F_rg.Row Case Is <= 18: Clas = "4م1 ف1" Case Is <= 19: Clas = "4م1 ف2" End Select Select Case F_rg.Column Case 5: col = 5 Case 7: col = 6 Case 9: col = 7 Case 11: col = 8 Case 13: col = 9 End Select Pr.Cells(F_rg.Row, col) = F_rg & " / " & F_rg.Offset(, -1) _ & ": " & Clas Set F_rg = Ak.Range("D8:M29").FindNext(F_rg) Ad2 = F_rg.Address If Ad1 = Ad2 Then Exit Do Loop End If Next End Sub الملف مرفق allaoua.xlsm

في هذا الخالة 1-السطر داخل المربع الأحمر لا جاحة له 2 أضيفي ما موجود بالمربع الأزرق

ولكن لم يحدث شى لأن الييانات يتم ترحليها مكررة مرة بعد اخرى (بالتالي الماكرو يمسح المكرر ولا يظهرها الا مرة واحدة) حربي تتبع تالماكرو بتحديد صفحة One مثلاُ و الضغظ على المفتاح F8 مرة يعد احرى لمشاهدة خطوات الماكرو وما يحدث في هذه الصفحة و هكذا يظهر لك ان لا شيء يحدث بينما قي الحقيقة الماكرو قام بوظيفته و مسح المكرر جربي تغيير شيئاً ما فيها أو ان تضيفي اليها شيئاُ ما ونفذي الماكرو من جديد

التعديل المطلوب

جرب هذا الكود Option Explicit Sub auto_formula() Dim Mx% With Sheets("النتيجة") Mx = .Cells(Rows.Count, "B").End(3).Row .Range("A10").Resize(Mx - 9).Value = _ Evaluate("Row(1:" & Mx - 9 & ")") With .Range("AK10").Resize(Mx - 9, 3) .Formula = _ "=IF($AJ10=AK$7,COUNTIF($AJ10:$AJ$10,$AJ10),"""")" .Value = .Value End With End With End Sub

تم انشاء ماكرو يقوم يهذا العمل (Print_Only _One) 1-اذا كانت الخلية H5 تحتوي على عدد اكبر من المطلوب ( يعني عدد المشتركين او عدد الأسماء) او عدد سالب او صفر او فارغة فأن الماكرو يسجلها 1 وبالتالي يستخرج أول مشترك 2- الماكرو بعمل على عدد المشتركين (مثلاً اذا كتبت 4 في الخلية H5 فإن الماكرو بستحرج رايع مشترك وليس الصف رفم 4) 3- الماكرو القديم ما زال يعمل في حال اردت طباعة الكل دفعة واحدة Option Explicit Dim S As Worksheet Dim B As Worksheet Dim last%, i%, Nb% Dim dic As Object Dim Mon_array Dim Itm Dim rg As Range '++++++++++++++++++ 'Other macro to Ptint One fatura Sub Fatura_Only_One() Set S = Sheets("Source") Set B = Sheets("By_one") Set dic = CreateObject("Scripting.Dictionary") last = S.Cells(Rows.Count, 1).End(3).Row S.Range("A4").Resize(last, 9).Interior.ColorIndex = xlNone For i = 4 To last If Not IsEmpty(S.Cells(i, 2)) Then Mon_array = Application.Transpose _ (S.Cells(i, 1).Resize(, 9)) Mon_array = Join(Application.Transpose(Mon_array), "*") dic(dic.Count) = Mon_array End If Next If dic.Count Then If Val(B.Range("H5")) <= 0 Or _ Val(B.Range("H5")) > dic.Count Then B.Range("H5") = 1 Else B.Range("H5") = Int(B.Range("H5")) End If Nb = Int(B.Range("H5")) - 1 B.Range("E6").Resize(9) = _ Application.Transpose(Split(dic.Items()(Nb), "*")) Set rg = S.Range("B1:B" & last).Find(B.Range("E7"), lookat:=1) If Not rg Is Nothing Then S.Cells(rg.Row, 1).Resize(, 9).Interior.ColorIndex = 35 End If '========================== B.PrintPreview ' '======================== End If Set dic = Nothing End Sub Bab Salam_New.xlsm

انت لم تذكر هذا الشيء في سؤالك ساعمل على ما تريد (ماكرو آخر)

تم وضع الكود اللازم 1- الكود يعطي معاينة قبل الطياعة 2- لجعله يطبع مباشرة استبدل ما موجود في الكود بين علامات اليساوي "============" بــ B.PrintOut Option Explicit Dim S As Worksheet Dim B As Worksheet Dim last%, Ro%, i% Dim dic As Object Dim Mon_array Dim Itm '++++++++++++++++++++++++++++++++ Sub Fatura_One() Set S = Sheets("Source") Set B = Sheets("By_one") Set dic = CreateObject("Scripting.Dictionary") last = S.Cells(Rows.Count, 1).End(3).Row S.Range("A4").Resize(last, 9).Interior.ColorIndex = xlNone For i = 4 To last If Not IsEmpty(S.Cells(i, 2)) Then S.Cells(i, 1).Resize(, 9).Interior.ColorIndex = 35 Mon_array = Application.Transpose _ (S.Cells(i, 1).Resize(, 9)) Mon_array = Join(Application.Transpose(Mon_array), "*") dic(dic.Count) = Mon_array End If Next If dic.Count Then For Each Itm In dic.items() B.Range("E6").Resize(9) = _ Application.Transpose(Split(Itm, "*")) '========================== B.PrintPreview '======================== Next End If Set dic = Nothing End Sub الملف مرفق Bab Salam.xlsm

جرب هذا الملف الماكرو يجد اخر خلية تحتوي الكلمة و يحدد الصف 1- اختر الكلمة التي تريدها من الخلية C1 ثم اضغط الزر الازرق Option Explicit Sub select_row() Dim rg As Range Dim i#, Ro#, Nb# Ro = Cells(Rows.Count, "O").End(3).Row Range("A4:A" & Ro).Rows.Hidden = True For i = Ro To 4 Step -1 If Cells(i, "O") = Range("C1") Then Nb = i Exit For End If Next If Nb > 0 Then Cells(Nb, 1).EntireRow.Hidden = False Range("A" & Nb).Resize(, 25).Select Else Range("A4:A" & Ro).Rows.Hidden = False End If End Sub '+++++++++++++++++ Sub show_rows() ActiveSheet.Cells.Rows.Hidden = False End Sub الملف مرفق Kassim.xlsm

مجدداً حلايا لا علاقة لها بالجدول تضاف اليه هذا الملف يحتوي على صفحتين (اختر ما تريد ) كل واحد الماكرو الخاص بها My_test.xlsm

في هذه الحالة لا حاجة للفلتر (معادلة بسيطة) Fahd.xlsx

جرب هذا الكود Option Explicit Sub filter_me() Dim T As Worksheet Dim S As Worksheet Dim Rg As Range Dim Ro Dim cret$ Set S = Sheets("Source") Set T = Sheets("Target") Set Rg = S.Range("E2").CurrentRegion S.AutoFilterMode = False T.Range("E2").CurrentRegion.Clear cret = T.Range("A1") Rg.AutoFilter 3, cret Rg.SpecialCells(12).Copy With T.Range("E2") .PasteSpecial (4) .PasteSpecial (12) End With S.AutoFilterMode = False Application.CutCopyMode = False Ro = T.Range("E2").CurrentRegion.Rows.Count If Ro > 1 Then T.Range("E3").Resize(Ro - 1) = _ Evaluate("Row(1:" & Ro - 1 & ")") End If T.Range("E2").Select End Sub الملف مرفق f16.xlsm

للمرة الــ 100 بعد الألف (يجب ان يكون الجدول مستقلاً عن كل الخلايا التي لا علاقة له بها 1- للمرة الأخيرة اقوم بالمساعدة دون هذه الميزة (تم ادراج صف فارغ لتحقيق ذلك الصف رقم 3 مخفي) الكود Sub Salim_Macro() Application.ScreenUpdating = False Dim My_max% Dim Cont As Integer Dim Ro Cont = Range("H1").Value My_max = Range("A4").CurrentRegion.Rows.Count If My_max = 1 Then GoTo End_Me With Range("A4").CurrentRegion. _ Offset(1).Resize(My_max - 1) _ .Columns(1) .ClearContents .Offset(, 7).ClearContents End With With Range("B4:H" & My_max + 3) .Sort .Columns(4), xlAscending, Header:=1 .Sort .Columns(3), xlAscending, Header:=1 .Sort .Columns(6), xlDescending, Header:=1 End With Range("a5").Resize(My_max - 1) = _ Evaluate("Row( 1:" & My_max - 1 & ")") Range("H5").Resize(My_max - 1).Formula = _ "=INT((ROWS($A$1:A1)-1)/" & Cont & ")+1" Range("A4:H" & My_max).Value = _ Range("A4:H" & My_max).Value End_Me: Application.ScreenUpdating = True End Sub الملف مرفق Moustsfa_Sort.xlsm

لا بمكن جذف خلية (أو أكثر ) منفردين من الأكسل ) ماذا ستضع مكانها ؟؟؟ لقاح لفيروس كورونا مثلاً لذلك هناك خياران: 1- أمّا ان تجذف صف (أو عدة صفوف )بكاملها 2- أمّا عامود ( أو عدة اعمدة ) بكاملها

لم افهم شيئاً مما تريد و أين الشيت Result

تفعل كما في الصورة

الكود Sub CustomSort() 'Excel VBA to Sort data in a custom list Dim r As Range Dim rng As Range Set r = Sheets("Target").Range("A6", Range("L" & Rows.Count).End(xlUp)) Set rng = Sheets("Target").Range("F1:F4") On Error Resume Next Application.AddCustomList rng r.Sort key1:=[L6], order1:=1, ordercustom:=Application.CustomListCount + 1, _ key2:=[J6], order2:=2, Header:=1 Application.DeleteCustomList Application.CustomListCount End Sub