سليم حاصبيا

من باب العرفان بالجميل واحتراماً لشيء يدعى "حقوق الملكية الفكرية" كان يجب عليك ان تذكر من وضع لك الكود الذي تعمل عليه في الملف تم التعديل على الكود كما تريد Option Explicit Sub ABSCENT_new() Application.Calculation = xlCalculationManual Dim K As Worksheet, A As Worksheet Dim Ro_K%, col%, Ro_A%, i%, m%, t%: t = 1 Dim ALL$, ALPHA$, Str$: Str = "غ" ALL$ = " ": ALPHA = " " Set K = Sheets("keab"): Set A = Sheets("arhkeab") Ro_K = K.Cells(Rows.Count, 2).End(3).Row If Ro_K < 5 Then Exit Sub Ro_A = A.Cells(Rows.Count, 2).End(3).Row m = IIf(Ro_A < 5, 5, Ro_A + 1) For i = 5 To Ro_K If Application.CountIf(K.Cells(i, 6).Resize(1, 31), Str) = 0 Then _ GoTo My_next A.Cells(m, 2).Resize(, 2).Value = _ K.Cells(i, 2).Resize(, 2).Value For col = 6 To 36 If K.Cells(i, col) = Str Then ALL = ALL & Day(K.Cells(4, col)) & "-" ALPHA = ALPHA & K.Cells(3, col) & "-" t = t + 1 End If Next col If t > 1 Then With A.Cells(m, 4) .Value = Mid(ALL, 1, Len(ALL) - 1) .Offset(, 1) = Mid(ALPHA, 1, Len(ALPHA) - 1) .Offset(, 2) = t - 1 .Offset(, 3) = K.Cells(2, "T") .Offset(, 4) = Year(Date) End With m = m + 1 End If My_next: t = 1 ALL = " ": ALPHA = " " Next i Application.Calculation = xlCalculationAutomatic End Sub Tarhil_3iyab (2).xlsm

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

و نحن عند الوقوف على مشاركة بدون ملف مرفق لا نعمل

لا أعلم لماذا كل هذه التعقيدات في الملف يوزر فورم و تكس بوكس الى ما هنالك انظر الى هذا الملف البسيط My_facture.xlsm

جرب هذا الكود Private Sub UserForm_Activate() Dim x, dic As Object Set dic = CreateObject("Scripting.Dictionary") With Sheets("الأرشيف") x = 4 Do Until .Cells(x, 4) = vbNullString dic(.Cells(x, 4).Value) = vbNullString x = x + 1 Loop Me.ListBox1.List = dic.keys End With Set dic = Nothing End Sub

لغاية الان لا أعرف ما المطلوب من الملف هناك اوقات بالجدول مثل 800:10 او ام3 الخ... لا أعرف من اين تأتي بها الافضل عمل كود لاستخراج ما تريد لان المعادلات هنا كثيرة جداَ مما يثقل الملف زيادة عن اللزوم حوالي (2 ميغا)

الخطأ في المعادلة الخلية T5 يجب ان تكون هكذا (Ctrl+Shift+Enter) حتى تحصل على العنوان الصحيح P!$CK$4:$DF$4 وليس P!$CK$4:$DF$17 ="P!"&ADDRESS(4,MIN(IF(MONTH(P!$D$3:$HQ$3)=$R$5,COLUMN($D$3:$HQ$3))))&":"&ADDRESS(4,MIN(IF(MONTH(P!$D$3:$HQ$3)=$R$5,COLUMN($D$3:$HQ$3)))+$S$5-1)

هذا الكود ولا لزوم للخلقات التكرارية Private Sub ToggleButton1_Click() If ToggleButton1 = True Then Call HideBlankRows: ToggleButton1.Caption = "Show_All" Else Call Show_all: ToggleButton1.Caption = "Filter_Me" End If End Sub '++++++++++++++++++++++++++++++++++ Sub HideBlankRows() Dim r%, My_RG As Range Set My_RG = Range("A11").CurrentRegion r = My_RG.Rows.Count My_RG.Offset(1).Resize(r - 1).AutoFilter 6, _ Criteria1:="<=" & Range("k2") End Sub '+++++++++++++++++++++++++ Sub Show_all() If ActiveSheet.AutoFilterMode Then Range("A10").CurrentRegion.AutoFilter End If End Sub الملف مرفق FILTR_No_Filter.xlsm

جرب هذا الماكرو Sub Fil_combo() Dim k, col, arr(), i%: i = 1 For k = 1 To Sheets.Count col = Sheets(k).Tab.Color If col Then ReDim Preserve arr(1 To i) arr(i) = Sheets(k).Name i = i + 1 End If Next With Me.ComboBox1 .List = Split(Join(arr, ","), ",") .Value = .List(0) End With End Sub COMBO_fil.xlsm

تم العمل كما تريد الكود يلون الصفوف الغريبة اوتو ماتيكياً Option Explicit Sub test() Dim RgA As Range, RgC As Range Dim Find_rg As Range, Rgl As Range Dim Dic_Yes As Object Dim m%, x%, R%, arr Set RgA = Sheets(1).Range("A4", Range("A3").End(4)) Set RgC = Sheets(1).Range("C4", Range("C3").End(4)) '=========================== Set Rgl = Sheets(1).Range("L4").CurrentRegion R = Rgl.Rows.Count If R > 1 Then Rgl.Offset(1).Resize(R - 1).Clear End If '============================ Set Dic_Yes = CreateObject("Scripting.Dictionary") For x = 1 To RgA.Rows.Count Set Find_rg = RgC.Find(RgA.Cells(x), lookat:=1) If Not Find_rg Is Nothing Then R = Find_rg.Row arr = Sheets(1).Cells(R, 3).Resize(, 8).Value arr = Application.Transpose(Application.Transpose(arr)) Dic_Yes.Add m, Join(arr, "*") m = m + 1 End If Next For x = 0 To Dic_Yes.Count - 1 Range("L" & x + 4).Resize(, 8).Value = Split(Dic_Yes.Item(x), "*") Next x = x + 4 For m = 1 To RgC.Rows.Count If IsError(Application.Match(RgC.Cells(m), RgA, 0)) Then RgC.Cells(m).Resize(, 8).Copy Cells(x, "L") Cells(x, "L").Resize(, 8).Interior.Color = RGB(0, 204, 255) x = x + 1 End If Next With Range("l4").Resize(x - 4, 8) .Value = .Value .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 End With Set RgA = Nothing: Set RgC = Nothing Set Find_rg = Nothing: Set Rgl = Nothing Set Dic_Yes = Nothing: Erase arr End Sub Farz1.xlsm

ممكن هذا الشيء ان يكون المطلوب my_sum.xlsx

كان من المفروض ان تذكر المشاركة الثّانية رأساُ لعدم اهدار الوقت باشياء غير مدروسة الكود Option Explicit Sub test() Dim RgA As Range, RgC As Range Dim Find_rg As Range, Rgl As Range Dim Dic_Yes As Object Dim m%, x%, R%, arr Set RgA = Sheets(1).Range("A4", Range("A3").End(4)) Set RgC = Sheets(1).Range("C4", Range("C3").End(4)) '=========================== Set Rgl = Sheets(1).Range("L4").CurrentRegion R = Rgl.Rows.Count If R > 1 Then Rgl.Offset(1).Resize(R - 1).Clear End If '============================ Set Dic_Yes = CreateObject("Scripting.Dictionary") For x = 1 To RgA.Rows.Count Set Find_rg = RgC.Find(RgA.Cells(x), lookat:=1) If Not Find_rg Is Nothing Then R = Find_rg.Row arr = Sheets(1).Cells(R, 3).Resize(, 8).Value arr = Application.Transpose(Application.Transpose(arr)) Dic_Yes.Add m, Join(arr, "*") m = m + 1 End If Next For x = 0 To Dic_Yes.Count - 1 Range("L" & x + 4).Resize(, 8).Value = Split(Dic_Yes.Item(x), "*") Next x = x + 4 For m = 1 To RgC.Rows.Count If RgC.Cells(m).Interior.ColorIndex > 0 Then RgC.Cells(m).Resize(, 8).Copy Cells(x, "L") x = x + 1 End If Next With Range("l4").Resize(x - 4, 8) .Value = .Value .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 End With Set RgA = Nothing: Set RgC = Nothing Set Find_rg = Nothing: Set Rgl = Nothing Set Dic_Yes = Nothing: Erase arr End Sub الملف Farz.xlsm

بعد اذن الاخ علي جرب هذا الكود Option Explicit Sub Salim() Dim My_rg1 As Range, RO%, m%, n%, x% Dim Arr1, Ful_arr(), Arr2() Set My_rg1 = Range(Sheets(1).Range("A4"), Sheets(1).Range("A4").End(4)) Arr1 = Application.Transpose(My_rg1) RO = Sheets(2).Cells(Rows.Count, 1).End(3).Row Sheets(2).Range("C4").CurrentRegion.Clear m = 1: n = 1 For x = 4 To RO If IsError(Application.Match(Sheets(2).Range("A" & x), Arr1, 0)) Then ReDim Preserve Arr2(1 To m) Arr2(m) = Sheets(2).Range("A" & x).Value m = m + 1 Else ReDim Preserve Ful_arr(1 To n) Ful_arr(n) = Sheets(2).Range("A" & x).Value n = n + 1 End If Next With Sheets(2).Range("C4").Resize(n - 1) .Value = Application.Transpose(Ful_arr) .Borders.LineStyle = 1 .Interior.ColorIndex = 20 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 If m <> 1 Then With .Offset(n - 1).Resize(m - 1) .Value = Application.Transpose(Arr2) .Borders.LineStyle = 1 .Interior.ColorIndex = 19 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 End With End If End With Erase Arr1: Erase Ful_arr(): Erase Arr2() End Sub الملف مرفق Tartib.xlsm

جرب هذا الكود لتثبيت Text Box Private Sub TextBox1_Change() lr = Range("d" & Rows.Count).End(xlUp).Row ActiveSheet.Range("$A$3:$S$" & lr) _ .AutoFilter Field:=4, Criteria1:="=" & ActiveSheet.TextBox1.Text & "*" With ActiveSheet.TextBox1 .Top = Cells(2, 2).Top: .Left = Cells(1, 1).Left + 150 .Width = 150: .Height = 30 End With End Sub '+++++++++++++++++++++++++ Private Sub Worksheet_Activate() With ActiveSheet.TextBox1 .Top = Cells(2, 2).Top: .Left = Cells(1, 1).Left + 150 .Width = 150: .Height = 30 End With End Sub الملف مرفق MY_Saerch.xlsm

اولاً يجب ازالة دمج الحلايا (علة العلل لكل معادلة او كود) من الصفحة P الأعمدة 1و 2 و 3 ثانياً أنت لم تذكر للاكسل عن اية سنة تريد جمع ايام اشهر جانفي لذلك قام البرنامج بجمع الايام عن كل اشهر جانفي لكل السنوات تم معالجة الامر REpport.rar

جرب هذا الملف ATM_BANK.xlsx

جرب هذا الماكرو Option Explicit Sub MY_SUM() Dim sh As Worksheet, m As Worksheet Dim t As Long Set m = Sheets("mine") For Each sh In Sheets If sh.Name Like "[a-zA-Z]" & "*#" Then _ t = t + Application.CountIf(sh.Range("I:I"), m.Range("A8")) Next m.Range("B8") = t End Sub

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

تم التعديل على الكود لا يمكن عمل هذا الشيء بالمعادلات Option Explicit Sub New_code_Modifier() Rem Created By Salim Hasbaya On 27/1/2020 Application.ScreenUpdating = False Dim oBJ As Object Dim S As Worksheet Dim cel As Range, my_rg As Range, F_rg As Range Dim i%, ro%, col% Dim First_ad$, Act_ad$ Set oBJ = CreateObject("System.Collections.arraylist") Set S = Sheets("salim") '============================== For Each cel In S.Range("H7:AC100") If Not oBJ.contains(cel.Value) _ And cel <> "" Then oBJ.Add cel.Value Next oBJ.Sort Set my_rg = S.Range("AF7").CurrentRegion If my_rg.Rows.Count <> 1 Then my_rg.Offset(1).Resize(my_rg.Rows.Count - 1, 12).ClearContents End If Cells(8, "AF").Resize(oBJ.Count).Value = _ Application.Transpose(oBJ.Toarray) For Each cel In S.Range("AF8").Resize(oBJ.Count) Set F_rg = S.Range("H7:AC100").Find(cel, lookat:=1) If Not F_rg Is Nothing Then First_ad = F_rg.Address: Act_ad = First_ad Do ro = S.Range(Act_ad).Row col = Application.Match(S.Cells(ro, 3), S.Range("AG7:AQ7"), 0) cel.Offset(, col) = S.Cells(ro, 2) Set F_rg = S.Range("H7:AC100").FindNext(F_rg) Act_ad = F_rg.Address If Act_ad = First_ad Then Exit Do Loop End If Next Set my_rg = Nothing: Set S = Nothing Set F_rg = Nothing: Set oBJ = Nothing Application.ScreenUpdating = True End Sub Prof_Madda_Final.xlsm

بواسطة هذا الكود يمكن ترتيب الاقسام في الجدول الثاني القوائم المنسدلة في الجدول الثاني ليس لها حاجة حيث ان الاقسام تظهر مرتبة بالنسبة لعدد الاقسام يمكن زيادتها الى قدر ما تشاء (ضمن النطاق H7:AC100 ) والماكرو يأخذها كلها دون تكرار وبالترتيب Option Explicit Sub New_code() Rem Created By Salim Hasbaya On 27/1/2020 Dim oBJ As Object Dim S As Worksheet Dim cel As Range, my_rg As Range, F_rg As Range Dim i%, ro%, col% Dim First_ad$, Act_ad$ Set oBJ = CreateObject("System.Collections.arraylist") Set S = Sheets("salim") '============================== For Each cel In S.Range("H7:AC100") If Not oBJ.contains(cel.Value) _ And cel <> "" Then oBJ.Add cel.Value Next oBJ.Sort Set my_rg = S.Range("AF7").CurrentRegion If my_rg.Rows.Count <> 1 Then my_rg.Offset(1).Resize(my_rg.Rows.Count - 1, 6).ClearContents End If Cells(8, "AF").Resize(oBJ.Count).Value = _ Application.Transpose(oBJ.Toarray) For Each cel In S.Range("AF8").Resize(oBJ.Count) Set F_rg = S.Range("H7:AC100").Find(cel, lookat:=1) If Not F_rg Is Nothing Then First_ad = F_rg.Address: Act_ad = First_ad Do ro = S.Range(Act_ad).Row Select Case Cells(ro, 3) Case "عربية": col = 1 Case "رياضيات": col = 2 Case "فرنسية": col = 3 Case "علوم ط": col = 4 Case "فيزياء": col = 5 End Select cel.Offset(, col) = S.Cells(ro, 2) Set F_rg = S.Range("H7:AC100").FindNext(F_rg) Act_ad = F_rg.Address If Act_ad = First_ad Then Exit Do Loop End If Next Set my_rg = Nothing: Set S = Nothing Set F_rg = Nothing: Set oBJ = Nothing End Sub الملف من جديد Prof_Madda_New.xlsm

انظر الى الملف المرفق فترى ان كل شيء كما تريد 12.xlsm

تم تصحيح الماكرو ليتعامل مع جميع الأعمدة Option Explicit Sub SALIM_S_Macro() Dim DIC As Object Dim S As Worksheet Dim my_rg, cel, F_rg As Range Dim First_ad$, Act_ad$, ro%, col% Set DIC = CreateObject("Scripting.Dictionary") Set S = Sheets("salim") For Each cel In Range("h7:Ac100") If cel <> vbNullString Then DIC(cel.Value) = vbNullString End If Next Set my_rg = S.Range("aF7").CurrentRegion If my_rg.Rows.Count <> 1 Then my_rg.Offset(1).Resize(my_rg.Rows.Count - 1, 6).ClearContents End If S.Range("aF8").Resize(DIC.Count) = _ Application.Transpose(DIC.keys) '+++++++++++++++++++++++++++++++++++++++++++++++ For Each cel In S.Range("aF8").Resize(DIC.Count) Set F_rg = S.Range("h7:Ac100").Find(cel, lookat:=1) If Not F_rg Is Nothing Then First_ad = F_rg.Address: Act_ad = First_ad Do ro = S.Range(Act_ad).Row Select Case Cells(ro, 3) Case "عربية": col = 1 Case "رياضيات": col = 2 Case "فرنسية": col = 3 Case "علوم ط": col = 4 Case "فيزياء": col = 5 End Select cel.Offset(, col) = S.Cells(ro, 2) Set F_rg = S.Range("h7:Ac100").FindNext(F_rg) Act_ad = F_rg.Address If Act_ad = First_ad Then Exit Do Loop End If Next DIC.RemoveAll: Set DIC = Nothing Set my_rg = Nothing: Set S = Nothing Set F_rg = Nothing End Sub Prof_Madda2.xlsm

اولاً ازالة دمج الخلايا من الجدول الثاني مطلوبة لحسن عمل الكود (تمت المعالجة) ثانياً تم تغيير اسم الصفحة الى SALIM لسهولة التعامل مع الكود من حيث النسخ واللصق (استعمل دائما أسماء الصفحات باللغة الأجنبية) ثالثاً تم تكبير الجدول الاساسي ليستوعب حوالي 100 صف الكود Option Explicit Sub TEST() Dim DIC As Object Dim S As Worksheet Dim cel As Range Dim my_rg As Range Set DIC = CreateObject("Scripting.Dictionary") Set S = Sheets("salim") For Each cel In Range("h7:Ac100") If cel <> "" Then DIC(cel.Value) = "" End If Next Set my_rg = S.Range("aF7").CurrentRegion If my_rg.Rows.Count <> 1 Then my_rg.Offset(1).Resize(my_rg.Rows.Count - 1, 6).ClearContents End If S.Range("aF8").Resize(DIC.Count - 1) = _ Application.Transpose(DIC.keys) S.Range("aG8").FormulaArray = _ "=IFERROR(INDEX($B$7:$B$100,MATCH($AF8&AG$7,$H$7:$H$100&$C$7:$C$100,0)),"""")" S.Range("aG8").AutoFill Destination:=S.Range("AG8:AK8") S.Range("AG8:AK8").AutoFill Destination:=S.Range("AG8:AK" & DIC.Count + 6) S.Range("AG8:AK" & DIC.Count + 6).Value = _ S.Range("AG8:AK" & DIC.Count + 6).Value DIC.RemoveAll: Set DIC = Nothing Set my_rg = Nothing: Set S = Nothing End Sub الملف مرفق Prof_Madda.xlsm

الكود المناسب Option Explicit Dim mY_rg As Range Private Sub Worksheet_selectionchange(ByVal Target As Range) Set mY_rg = Range("b2:b" & Cells(Rows.Count, 2).End(3)) Application.EnableEvents = False If Not Intersect(Target, mY_rg) Is Nothing Then Range("F1") = Intersect(Selection, mY_rg).Cells(1) End If Application.EnableEvents = True End Sub FIRST_CELL.xlsm

جرب هذا الملف My_Book.xlsx