سليم حاصبيا

تم التعديل على الكود (التاريخ والترقيم يدخل اوتوماتيكياً في الجدول الاول) لذلك لا داعي لادراجهما Private Sub insertbutton_Click() Fil_data End Sub '========================= Sub Fil_data() Dim nextRow As Long With Sheets("sheet1") nextRow = .Range("C10000").End(xlUp).Row + 1 .Range("B" & nextRow).Resize(, 8).Value = .Range("B7").Resize(, 8).Value .Range("D" & nextRow) = Date + Time .Range("B7") = Application.Max(Range("B14:b10000")) + 1 .Range("C7").Resize(, 7) = vbNullString .Range("D7") = Date + Time End With End Sub الملف مرفق samples_NEW.xlsm

لا يجب ادراج اي شيء العامود D من الجدول الثاني بل يمكن ادراج التاريخ في الخلية( D7) او ( D8) او في الثنتين معاً والكود ينقلها الى مكانها الصحيح في الجدول الثاني مع العلم انه يجب تنسيق العامود D من الجدول الثاني كتاريخ

جرب هذا الماكرو Private Sub CommandButton1_Click() insertbutton_Click End Sub '+++++++++++++++++++++++++++++++++ Sub insertbutton_Click() Dim x%, y%, nextRow%, rg_to_copy As Range Set rg_to_copy = Me.Range("b6").CurrentRegion x = rg_to_copy.Rows.Count If x = 1 Then Exit Sub y = rg_to_copy.Columns.Count nextRow = Me.Cells(Rows.Count, 2).End(3).Row + 1 Set rg_to_copy = rg_to_copy.Offset(1).Resize(x - 1) Me.Range("B" & nextRow). _ Resize(x - 1, y).Value = rg_to_copy.Value rg_to_copy.ClearContents End Sub الملف مرفق samples_BUTTON.xlsm

استبدل الى هذا الماكرو Sub remov_dup_new() Dim r%, col%, COL_1%, i%, k%, m%: m = 2 Dim dic As Object Dim My_rg As Range Set My_rg = Range("a1").CurrentRegion r = My_rg.Rows.Count: COL_1 = My_rg.Columns.Count Set My_rg = My_rg.Offset(1).Resize(r - 1) 'My_rg.Select Cells(1, COL_1 + 2).CurrentRegion.ClearContents For i = 2 To r Set dic = CreateObject("Scripting.Dictionary") col = Cells(r, Columns.Count).End(1).Column Cells(m, COL_1 + 2) = Cells(i, 1) For k = 2 To col + 1 dic(Cells(i, k).Value) = vbNullString Next k Cells(m, COL_1 + 3).Resize(, dic.Count) = dic.keys m = m + 1 dic.RemoveAll Next i Set dic = Nothing End Sub

هذا الماكرو يقوم بما تريد Option Explicit Sub TAKDIRAT() Dim Rg As Range, cel As Range Dim Note$ Set Rg = Range("A9", Range("A8").End(4)).Offset(, 9) Rg.ClearContents For Each cel In Rg If IsNumeric(cel.Offset(, -1)) Then Select Case cel.Offset(, -1) Case Is < 7: Note = "نتائج غير مقبولة" Case Is < 10: Note = "نتائج دون الوسط" Case Is < 12: Note = "نتائج متوسطة" Case Is < 14: Note = "نتائج حسنة" Case Is < 16: Note = "نتائج جيدة" Case Is < 18: Note = "نتائج جدة جداً" Case Else: Note = "نتائج ممتازة" End Select cel = Note End If Next End Sub الملف مع الكود Formules.xlsm

صديقي لا حاجة للكود في مثل هذا الحالة Formules.xls

لا ضرورة لهذه الاعمدة المساعدة من اجل القوائم المنسدلة تم معالجة الامر في الملف المرفق Tansik.xlsm

تم التعديل على الماكرو ليتناسب مع المطلوب Option Explicit Sub get_data_new() Dim S As Worksheet, T As Worksheet Dim Rg_T As Range, Cel_T As Range Dim Rg_S As Range, Cel_S As Range Dim Dc As Object, K Dim x%, lr%, m%: m = 5 Set S = Sheets("Source") Set T = Sheets("Target") Set Rg_T = T.Range("W5", Range("W4").End(4)) Set Rg_S = S.Range("C9", S.Range("C8").End(4)) Set Dc = CreateObject("Scripting.Dictionary") With T.Range("AA4").CurrentRegion.Offset(1) .Interior.ColorIndex = xlNo .ClearContents End With T.Range("AA5").Resize(, 3).Interior.ColorIndex = 40 For Each Cel_T In Rg_T K = Cel_T & " " & Trim(Cel_T.Offset(, 1)) For Each Cel_S In Rg_S If Cel_S & " " & _ Trim(Cel_S.Offset(, 1)) = K Then _ Dc(Cel_S.Offset(, -1).Value) = "" Next Cel_S With T.Cells(m, "AA") .Resize(Dc.Count) = _ Application.Transpose(Dc.keys) lr = .Parent.Cells(Rows.Count, "AA").End(3).Row .Parent.Cells(lr + 1, "AA").Resize(, 3) _ .Interior.ColorIndex = 40 .Offset(, 1).Resize(, 2) = _ Split(K, " ", 2) End With m = m + Dc.Count: Dc.RemoveAll Next Cel_T T.Range("AA" & lr + 1).Resize(, 3). _ Interior.ColorIndex = xlNo Set Dc = Nothing End Sub Fousoul_stds_with color.xlsm

الكود النهاني (مع الفرز حسب اللجان) و ادراج عدد اللجان اوتوماتيكياً حسب عدد الطلاب الاجمالي و عدد الطلاب في كل لجنة تغيير اسم الصفحة الى SALIM لحسن عمل الكود وعدم ظهور احرف غريبة في الكدو مما يؤثر على عملية نسخه ولصقه Option Explicit Sub Ahmed_Salim_Final() If ActiveSheet.Name <> "SALIM" Then Exit Sub Dim AA%, N%, i%, k%, Last_Row% Dim tt%: tt = 1 Dim m%: m = 8 With ActiveSheet AA = .Cells(Rows.Count, 2).End(3).Rows Last_Row = AA + 7 .[d2] = AA N = IIf([d2] Mod [d4] = 0, [d2] / [d4], Int([d2] / [d4]) + 1) .Range("D8", .Range("D7").End(4)).ClearContents For k = 1 To N For i = 1 To .[d4] .Cells(m, 4) = k m = m + 1 If m = Last_Row + 1 Then GoTo End_Me Next i Next k End_Me: .Range("D3") = Evaluate("=max(D8:D1000)") End With End Sub الملف النهائي distribution_Final.xlsm

أخي احمد الكود ممتاز من حبث الفكرة والاسلوب ولكن لا بد لي من اضافة بعض التعديلات عليه ليكون : 1-بشكل اقصر 2-بدون كل هذه الاوامر Select و Activate التي ترهق البرنامج دون فائدة Option Explicit Sub Ahmed_Salim2() Dim AA%, N%, i%, Last_Row% Dim tt%: tt = 1 AA = [d4] N = Int([d2] / AA) + 1 Last_Row = Cells(Rows.Count, 3).End(3).Row Range("D8", Range("D7").End(4)).ClearContents For i = 8 To Last_Row Range("D" & i) = tt tt = IIf(tt < AA, tt + 1, 1) Next Range("D3") = Evaluate("=COUNTIF(D8:D100,1)") End Sub distribution_Ah_Sal.xlsm

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

بعد تغيير اسماء الصفحات الى Source و Target نفذ هذا الكود Option Explicit Sub get_data() Dim S As Worksheet, T As Worksheet Dim Rg_T As Range, Cel_T As Range Dim Cel_S As Range, Rg_S As Range Dim Dc As Object, K Dim m%: m = 5 Set S = Sheets("Source") Set T = Sheets("Target") Set Rg_T = T.Range("W5", Range("W4").End(4)) Set Rg_S = S.Range("C9", S.Range("C8").End(4)) Set Dc = CreateObject("Scripting.Dictionary") T.Range("AA4").CurrentRegion.Offset(1).ClearContents For Each Cel_T In Rg_T K = Cel_T & Cel_T.Offset(, 1) For Each Cel_S In Rg_S If Cel_S & Cel_S.Offset(, 1) = K Then _ Dc(Cel_S.Offset(, -1).Value) = "" Next Cel_S T.Cells(m, "AA").Resize(Dc.Count) = _ Application.Transpose(Dc.keys) m = m + Dc.Count: Dc.RemoveAll Next Cel_T Set Dc = Nothing End Sub الملف مرفق Fousoul_stds.xlsm

جرب هذا الملف Cond_format.xls

بعد اذن الاخ احمد استبدل اسماء الصفحات الى Clas و Repport انا افضل دائماً ان تكون اسماء الصفحات باللغة الاجنبية (لحسن عمل الكود وعدم ظهور احرف غريبة في الكود) ضع في الخلية T1 الرقم تريده ونفذ هدا الكود Option Explicit Sub get_Repport() Dim i%, k, T%: T = 1 Dim CL As Worksheet, Rp As Worksheet Set CL = Sheets("Clas"): Set Rp = Sheets("Repport") Dim start_num%: start_num% = Rp.Range("T1") Dim arr(1 To 10, 1 To 2) For k = 1 To 2 For i = 5 To 45 Step 10 arr(T, 1) = i arr(T, 2) = IIf(T > 5, 9, 2) T = T + 1 Next i Next k k = 0 For i = LBound(arr) To UBound(arr) With Rp.Cells(arr(i, 1), arr(i, 2)) .Value = CL.Cells(start_num + k + 1, 3) .Offset(1) = CL.Cells(start_num + k + 1, 5) .Offset(2) = CL.Cells(start_num + k + 1, 2) .Offset(3) = CL.Cells(start_num + k + 1, 4) .Offset(4) = CL.Cells(start_num + k + 1, 6) .Offset(5) = CL.Cells(start_num + k + 1, 7) End With k = k + 1 Next End Sub الملف مرفق Joulous_2019.xlsm

و من يعمل على جداول فارغة؟؟!!!

جرب هذه المعادلة (بدون جدول اضافي) / (Ctrl+Shift+Enter) =INDEX($C$7:$E$8,MATCH($J$4,$B$7:$B$8,0),) INDEX($C$7:$E$8,,MATCH($J$3,$C$6:$E$6,0)) الملف مرفق File_Sa.xlsx

ربما ينفع هذا الكود Option Explicit Sub remov_dup() Dim r%, col%, i%, k%, m%: m = 2 Dim dic As Object r = Cells(Rows.Count, 1).End(3).Row Cells(2, "j").CurrentRegion.ClearContents For i = 2 To r Set dic = CreateObject("Scripting.Dictionary") col = Cells(r, Columns.Count).End(1).Column Cells(m, 10) = Cells(i, 1) For k = 2 To col dic(Cells(i, k).Value) = vbNullString Next k Cells(m, 11).Resize(, dic.Count) = dic.keys m = m + 1 dic.RemoveAll Next i Set dic = Nothing End Sub الملف مرفق Salim 3.xlsm

مع انك لم ترفع ملفاً للمعاينة وهذا مخالف لقانون المنتدى اليك هذا النموذج (على امل عدم تكرار هذه المشاركات) Moukafa2a.xlsx

جرب هذا الملف Jard.xls

يمكن ذلك بزيادة الدالة TRIM على المعادلة =IFERROR(TRIM(MID(SUBSTITUTE(SUBSTITUTE(A2,":","")," ","*",2),FIND("*",SUBSTITUTE(SUBSTITUTE(A2,":","")," ","*",2))+1,LEN(A2))),"") لتصبح هكذا =IFERROR(TRIM(MID(SUBSTITUTE(SUBSTITUTE(A2,":","")," ","*",2),FIND("*",SUBSTITUTE(SUBSTITUTE(A2,":","")," ","*",2))+1,LEN(A2))),"") الملف من جديد New_text_section.xls

بعد اذن اخي بن علية وزيادة في اثراء الموضوع هذه المعادلة =IFERROR(MID(SUBSTITUTE(SUBSTITUTE(A2,":","")," ","*",2),FIND("*",SUBSTITUTE(SUBSTITUTE(A2,":","")," ","*",2))+1,LEN(A2)),"") الملف مرفق text_section.xls

هذه المعادلة في الخلية J3 واسحب نزولاً 5 صفوف ونفس العادلة على باقي النطاق =SUMPRODUCT(($A$1:$A$150=I$2)*($G$1:$G$150=$I3)) الملف مرفق 2020_sal.xlsx

لا حاحة للكود في مثل هذه الحالة تكفي هذه المعادلة (Ctrl+Shift+Enter) =IF(ROWS($K$4:K4)>ABS(COUNTIF($D$4:$D$100,"<>"&$G$4)-COUNTBLANK($D$4:$D$100)),"",INDEX($D$4:$D$100,SMALL(IF($D$4:$D$100<>"",IF($D$4:$D$100<>$I$4,ROW($D$4:$D$100)-ROW($D$4)+1)),ROWS($K$4:K4)))) الملف مرفق Copie.xlsx

بعذ اذن الاخ علي وزيادة في اثراء الموضوع هذا الكود Option Explicit Sub Insert_rows() Dim lra%, i%, k% Dim dic As Object, Itm lra = Cells(Rows.Count, 1).End(3).Row On Error Resume Next Range("A1:A" & lra).SpecialCells(xlCellTypeBlanks). _ EntireRow.Delete On Error GoTo 0 lra = Cells(Rows.Count, 1).End(3).Row Set dic = CreateObject("Scripting.dictionary") For i = 1 To lra dic(Range("A" & i).Value) = _ Range("A" & i).Row Next For Each Itm In dic.items Rows(Itm + 1 + k).Insert k = k + 1 Next End Sub الملف مرفق Insert_Ro.xlsm

في هذه الحالة شيت Source هي شيت المصدر و شيت Salim هي شيت النتيجة الكود اللازم Option Explicit Dim My_rgA As Range, My_rgB As Range Dim r% '++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Set My_rgA = Sheets("Source").Range("A2", Sheets("Source").Range("A1").End(4)) Set My_rgB = Sheets("Source").Range("B2", Sheets("Source").Range("B1").End(4)) If Target.Cells.Count = 1 Then Select Case Target.Address Case "$E$3": get_valB Case "$F$3": get_valA End Select End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++++++++++++ Sub get_valB() If Application.CountIf(My_rgA, Range("E3")) Then r = My_rgA.Find(Range("E3"), lookat:=1).Row If r <> 0 Then Range("F3") = My_rgB.Cells(r - 1) Else Range("F3") = IIf(Range("E3") = "", "", "Not Found") End If End Sub '+++++++++++++++++++++++++++++++++++++ Sub get_valA() If Application.CountIf(My_rgB, Range("F3")) Then r = My_rgB.Find(Range("F3"), lookat:=1).Row If r <> 0 Then Range("E3") = My_rgA.Cells(r - 1) Else Range("E3") = IIf(Range("F3") = "", "", "Not Found") End If End Sub الملف الجديد Double_formula 2 Sheets.xlsm