سليم حاصبيا

لا يمكنك فعل هذا لان لكل ملف خصائصه من ناحية عدد الأعمدة فيه وبداية البيانات ونهايتها بالاضافة الى نوعيتها (نصوص أرقام الخ...) بل يمنكك تعديل الكود بما يتلائم مع وضعية الملف الذي تريد العمل عليه على فكرة تم التعديل قليلاُ على الملف السابق بحيث تستطيع عمل الفلترة على اي عامود من الجدول وليس فقط (Name1) تختار الحقل اولاً من الخلية B1 (يتم اطهار كافة البيانات) ومن ثم تحدد اي عنصر من هذا الحقل تريد من الخلية C1 الملف الجديد مرفق Filter_By_Select_by_col.xlsm

جرب هذل الملف أولاً الماكرو Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$C$1" Then Call filter_me(Range("A3").CurrentRegion, 6, Target.Value) End If Application.EnableEvents = True End Sub '=========================================== Sub Create_dat_val() Rem created By Salim Hasbaya On 17/9/2019 Dim s1 As Worksheet: Set s1 = Sheets("sheet1") Dim ro_n: ro_n = s1.Range("A3").CurrentRegion.Rows.Count Dim i% Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") With s1 For i = 4 To ro_n dict(.Range("F" & i).Value) = "" Next With .Range("c1").Validation .Delete .Add xlValidateList, Formula1:=Join(dict.keys, ",") End With End With dict.RemoveAll End Sub '=========================================== Sub filter_me(rg As Range, n, My_st) Rem created By Salim Hasbaya On 17/9/2019 If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData rg.AutoFilter End If rg.AutoFilter field:=n, Criteria1:=My_st End Sub '=========================================== Sub Show_Me_All() Rem created By Salim Hasbaya On 17/9/2019 If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData Range("A3").CurrentRegion.AutoFilter End If End Sub ثانياً الملف Filter_By_Select.xlsm

هذه المعادلة تضعها في F7 (او اينما تريد) وتسحب الى اليسار ثم نزولا ( استعمال Ctrl+Shift+enter وليس Enter وحدها) =IF(ISNUMBER(IF($B$4="","",SEARCH($B$4,$A7:$D7))),A7,"") الملف مرفق test-new.xlsx

جرب هذا الماكرو Option Explicit Private Fltr_range As Range, I_range As Range Private EHsaa As Worksheet, Tasj As Worksheet Private lr_EHsaa%, lr_Tasj, m% '=============================== Sub my_filter() Set EHsaa = Sheets("احصاء الغيابات") Set Tasj = Sheets("تسجيل الغيابات") lr_EHsaa = EHsaa.Cells(Rows.Count, 2).End(3).Row lr_Tasj = Tasj.Cells(Rows.Count, 2).End(3).Row Set Fltr_range = Tasj.Range("B6:E" & lr_Tasj) Set I_range = EHsaa.Range("T1:T6") lr_EHsaa = IIf(lr_EHsaa = 3, 4, lr_EHsaa + 1) Dim i% For i = 1 To I_range.Rows.Count Call Filter_FOR_Me(Fltr_range, 3, EHsaa.Range("T" & i)) Next EHsaa.Range("b3").Select Application.CutCopyMode = False Fltr_range.AutoFilter End Sub '============================================= Sub Filter_FOR_Me(rg As Range, n, St) rg.AutoFilter , field:=n, Criteria1:=St rg.Offset(1).Resize(rg.Rows.Count - 1).Copy EHsaa.Range("B" & lr_EHsaa).PasteSpecial xlValues m = EHsaa.Cells(Rows.Count, 2).End(3).Row + 1 lr_EHsaa = m + 1 End Sub الملف مرفق Abscence.xlsm

بارك الله بك استاذ علي و زيادة في توضيح الامور هذا الملف From To.xlsx

حاول التقليل من حجم الملف ( اكثر من 500 كيلو لمراقبة سير المعادلات)

اي موضوع ؟؟؟

جر ب هذا الشيء Evaluation _Salim.xlsx

تفضل الكود اولاً Option Explicit Sub find_Please() If ActiveSheet.Name <> "بنزين" Then Exit Sub Dim B As Worksheet: Set B = Sheets("بنزين") Dim M As Worksheet: Set M = Sheets("الموقف1") Dim r%, k% Dim M_R As Range Dim dic As Object Set M_R = M.Range("A2", M.Cells(Rows.Count, 1).End(3)).Resize(, 6) Set dic = CreateObject("Scripting.Dictionary") Dim My_word: My_word = B.Range("O1") Dim x%: x = M_R.Rows.Count: Dim i% Dim arr(1 To 4) arr(1) = "B": arr(2) = "F": arr(3) = "G": arr(4) = "H" B.Range("b2").Resize(1000, 8).ClearContents For i = 1 To x dic(M_R.Cells(i, 5).Value) = "" Next With B.Range("O1").Validation .Delete .Add xlValidateList, Formula1:=Join((dic.keys), ",") End With r = 2 For i = 1 To x If r - 1 > Application.CountIf(M_R, My_word) Then Exit For If M_R.Cells(i, 5) = My_word Then B.Cells(r, arr(1)) = M_R.Cells(i, 5) B.Cells(r, arr(2)) = M_R.Cells(i, 1) B.Cells(r, arr(3)) = M_R.Cells(i, 2) B.Cells(r, arr(4)) = M_R.Cells(i, 6) r = r + 1 End If Next Erase arr: dic.RemoveAll: Set M_R = Nothing: Set dic = Nothing Set M = Nothing: Set B = Nothing End Sub ثم الملف ثانياً (اختيار الاسم من القائمة المنسدلة المطاطة (لعدم الوقوع في خطأ الكتابة مسافة زائدة /مسافة ناقصة /خطأ املائي /أخطاء الهمزة / الخ... و لتوفير الوقت) استفسار .xlsm

استاذ نبيل ==== كود جيد والى الامام لكن ارجو تقبل هذه الملاحظات: 1-لا حاجة لعمل تنسيق على كامل خلايا الورقة (Cells.Select) طالما انه يهمك فقط نطاق معين منها 2-لا حاجة للــ SELECT (هذا الأمر التي يستعمله اكثر الناس مع انه لا لزوم له الا في بعض الحالات) لانه يهدر وقت الاكسل(و لو لجزء من مليون من الثّانية الذي تعتبره الذاكرة شيئاً مهماً) 3- تغيير التحديد الى A1 ايضا لا لزوم له الكود كما يجب ان يكون Sub Hidezerovalue() Range("B3:J6").NumberFormat = "0; -0;;@" End Sub '============================= Sub showzerovalue() Range("B3:J6").NumberFormat = "General" End Sub

جرب هذا الملف kashF.xlsm

للمزيد بعد اذن الاخ علي هذه المعادلة =COUNTIF(A$2:A2,A2)

جرب هذا الماكرو بالنسبة للملفات HR_test Option Explicit Sub copy_data() Dim S As Worksheet: Set S = Sheets("Shift Schedule") Dim O As Worksheet: Set O = Sheets("Overtime") Dim A As Worksheet: Set A = Sheets("Attendance") Dim Final_S: Final_S = S.Cells(Rows.Count, 1).End(3).Row Dim Final_O: Final_O = O.Cells(Rows.Count, 1).End(3).Row Dim Final_A: Final_A = A.Cells(Rows.Count, 1).End(3).Row Dim Rs As Range: Set Rs = S.Range("A8:AG" & Final_S) Dim RO As Range: Set RO = O.Range("A8:AG" & Final_O) Dim RA As Range: Set RA = A.Range("A8:AG" & Final_A) Dim i%, xO%, XA%, xx% xO = RO.Rows.Count: XA = RA.Rows.Count Rs.ClearContents i = 1: xx = 8 Do Until i > xO S.Cells(xx, 1) = RO.Cells(i, 1) S.Cells(xx, 3).Resize(, RO.Columns.Count - 2).Value = _ RO.Cells(i, 3).Resize(, RO.Columns.Count - 2).Value i = i + 1: xx = xx + 2 Loop i = 1: xx = 9 Do Until i > XA S.Cells(xx, 1) = RA.Cells(i, 1) S.Cells(xx, 3).Resize(, RA.Columns.Count - 2).Value = _ RA.Cells(i, 3).Resize(, RA.Columns.Count - 2).Value i = i + 1: xx = xx + 2 Loop End Sub الملف مرفق Salim_TEST3.xlsm

في الملف المرفق عندنا جدول من A1 الى F8 وعلى المستخدم ان يملؤه بالترتيب (في كل صف) مثلا اذا قمت بالكتابة في الخلية D4 و كان ما قبلها فارغاً (C4) يقوم الدكتور اكسل بمسح ما قمت بكتابته بعد الخروج من الخلية دون انذار و اذا حذفت اول خلية بالصف يتم حذف كامل الصف الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("A1:F8")) Is Nothing Then If Target.Count = 1 Then del_to_Column (Target.Row) End If End If Application.EnableEvents = True End Sub '================================ Sub del_to_Column(R) Dim My_rg As Range, R_Empty As Range Dim Col% Set My_rg = Cells(R, 1).Resize(, 6) Col = My_rg.Columns.Count Set R_Empty = My_rg.Find(vbNullString, After:=Cells(R, 6)) If Not R_Empty Is Nothing Then R_Empty.Resize(, Col - R_Empty.Column + 1) = vbNullString End If End Sub الملف مرفق write_by_order.xlsm

أضغط Ctrl+ F1 لاخفاءه و مرة اخرى لاظهاره

ما هو برده الخليتين الاولى والثالثة (باللون الابيض) مشتركين مع نفس الرقم في العمود التاني لماذا لا يتم اختيارهما مثلا؟؟؟!!!!

الموضوع غير مفهوم نهائياُ مثلا من اين اتى الرقم 6500000362 الموجود قي العامود في اول العامود K الافضل ان ترفع جدولاً لا يتحوي على ارقام كبيرة (الملايين ) حتى يمكن التمييز بينها بواسطة النظر فلا يمكن ان تتذكر رقم بمئات الملايين والتفتيش عنه بين مجموعة ارقام بنفس المستوى (يكفي من 1 الى 10) او حروف ( ...... A B C ) و من ثم بعد اكتشاف المعادلة اللازمة تستطيع ان تضع الارقام التي تريدها B2B.XLSX

اولا لا يمكن العمل على صورة (ارفاق الملف) ثانياً ارجو توضيح السؤال هل تريد : 1-ان تستخلص الاشياء المشتركة بين العامودين ؟؟؟؟ 2-ان تستخاص ما موجود في الاول وليس في الثاني ؟؟؟ 3- ان تستخاص ما موجود في الثاني وليس في الاول ؟؟؟

جرب هذه المعادلة =INDEX($A$2:$A$15,MODE(MATCH($A$2:$A$15,$A$2:$A$15,0))) الملف مرفق minwal.xlsx

جرب هذا الملف (ليس فقط الشهر بل السنة ايضاً) MY_DATE.xlsx

بعد اذن اخي حسين هذا الكود Option Explicit Sub copy_Form_to() Dim M As Worksheet: Set M = Sheets("Main") Dim L As Worksheet: Set L = Sheets("list") If Not IsNumeric(L.Range("g5")) Or L.Range("g5") = 0 Then Exit Sub If Not IsNumeric(L.Range("I5")) Or L.Range("I5") = 0 Then Exit Sub Dim lrM%: lrM = M.Cells(Rows.Count, 3).End(3).Row Dim RgC As Range: Set RgC = L.Range("C6:C35") L.Range("b5").CurrentRegion.Offset(1).ClearContents Dim My_Min: My_Min = Application.Min(L.Range("g5:I5")) Dim My_Max: My_Max = Application.Max(L.Range("g5:I5")) If My_Max > lrM - 2 Then My_Max = lrM - 2 Dim t%, K% Dim r%, c%, X% r = 6: c = 3 My_Min = Int(Abs(My_Min)): My_Max = Int(Abs(My_Max)) For t = My_Min To My_Max On Error Resume Next X = M.Range("c:c").Find(t, lookat:=1).Row If Err.Number Then Err.Number = 0: GoTo next_t If X Then K = K + 1 If K = (RgC.Rows.Count) * 2 + 1 Then Exit For L.Cells(r, c - 1) = t: L.Cells(r, c) = M.Cells(X, 4) r = r + 1 If K = RgC.Rows.Count Then r = 6: c = c + 2 End If next_t: Next End Sub الملف مرفق aaaa.xlsm

كان يجب تحميل مثال عما تريد لكن جرب هذا الملف wwithout Breakets.xlsx

لجعل الكود اسرع بحوالي 50 مرة 1-عملية Select تأخذ وقتاً طويلاً لذلك في اي كود يجب ان نتغاضى عنها قدر الامكان 2-استعمال With و End With مهمة جداً لتسريع اي كود 3-اعادة الحساب مع كل خلية تأخذ وقتاَ ايضاُ لذلك تم استعمال Calculation =Manual ليوقف البرنامج جميع العمليات الحسابية ريثما ينتهي الكود من عمله 4- اعادة Calculation الى Automatic بعد انتهاء الكود Option Explicit Sub REMOVE_DUPL_NEW() Dim S As Worksheet: Set S = Sheets("salim") Dim F2 As Worksheet: Set F2 = Sheets("Feuil2") With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With With S .Range("A1") = F2.Range("a1") .Range("a3").CurrentRegion.Clear F2.Range("a3").CurrentRegion.Copy _ S.Range("a3") .Range("a3").CurrentRegion.Value = _ .Range("a3").CurrentRegion.Value .Range("a3").CurrentRegion.RemoveDuplicates _ Columns:=Array(2, 6, 7, 8, 9, 10 _ , 11, 12, 13, 14, 15), Header:=1 End With With Application .CutCopyMode = False .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Set S = Nothing: Set F2 = Nothing End Sub الملف مرفق Classeur3_salim.xlsm

هذا المامرو ربما يفي بالغرض Option Explicit Sub ConvertFormulasToValues() Dim r As Long Dim i As Byte r = Range("A" & Rows.Count).End(xlUp).Row Dim st1$: st1 = "=100" Dim st2$: st2 = "=IF(C8=""ناصر"",666.65,120.25)" Dim st3$: st3 = "=IF(C8=""سليم"",""ممتاز"","""")" Dim st4$: st4 = "=IF(D8=""اوفسينا"",""المنتدى الاول"","""")" With Cells(8, 5).Resize(r) .Formula = st1 .Offset(, 1).Formula = st2 .Offset(, 2).Formula = st3 .Offset(, 3).Formula = st4 .Resize(, 4).Value = .Resize(, 4).Value End With End Su

ممكن هذا المثال يبسط الأمور Option Explicit Sub Fast_macro() Dim La#: La = Cells(Rows.Count, 1).End(3).Row With Range("D2").Resize(La - 1) .Value = vbNullString .Formula = "=SUM(A2:B2)" .Value = .Value End With End Sub الملف مرفق value.value.xlsm