سليم حاصبيا

جرب هذا الماكرو فقط اكنب رقم الطالب في B فيظهر اسمه في C ثم اكتب "غ" اينما تريد (أو امسح الــ "غ" اذا اردت تعديل ذلك) ثم اضغظ الزر Run لا تثم بالترقيم في العامود A لانه يدرج الترقيم اوتومانيكياً Option Explicit Sub Get_abscent() Dim S1 As Worksheet, S2 As Worksheet Dim Horz As Range, Vert As Range Dim M%, i%, y%, X% Set S1 = SHEET1: Set S2 = SHEET2 M = Application.Max(S2.Range("A6").Resize(100)) + 4 Set Vert = S1.Range("E4:AS4").Find(S2.Range("E2"), lookat:=1) If Vert Is Nothing Then Exit Sub y = Vert.Column For i = 5 To M Set Horz = S1.Range("C4:C100"). _ Find(S2.Range("B" & i), lookat:=1) If Not Horz Is Nothing Then X = Horz.Row S1.Cells(X, y) = S2.Cells(i, "D") S1.Cells(X, y).Interior.ColorIndex = _ IIf(S2.Cells(i, "D") = "", xlNone, 6) End If Next Set S1 = Nothing: Set S2 = Nothing Set Horz = Nothing: Set Vert = Nothing End Sub الملف مرفق Nour_Vise_versa.xlsm

بعد إذن الاستاذ هادى (بدون اكواد) Nour_ahmad.xlsx

هذه المعادلة في AA4 واسحب يساراً و نزولا =IF(SUMPRODUCT(--($C$2:$Z$2=AA$2),$C4:$Z4)/6=0,"",SUMPRODUCT(--($C$2:$Z$2=AA$2),$C4:$Z4)/6) الملف مرفق Samah_sumpr.xlsb

الملف الذي رفعته لا يمكن تنزيله (Unavailable) لذلك اقترح تجربة هذا الملف Option Explicit Function Remove_int(Txt, k) Dim Salim_Match, n With CreateObject("VBScript.RegExp") .Global = True .Pattern = "(\d)" If .Test(Txt) Then Set Salim_Match = .Execute(Txt) If k >= Salim_Match.Count Then n = Salim_Match(Salim_Match.Count - 1).FirstIndex Remove_int = Mid(Txt, 1, n) Else n = Salim_Match(k).FirstIndex + 1 Remove_int = Mid(Txt, 1, n - 2) _ & Mid(Txt, n, Len(Txt)) End If Else Remove_int = "N/A" End If End With End Function '+++++++++++++++++++++++++++++++++ الملف مرفق Remove_Only_One_Number.xlsm

اتســاءل من عنده الوقت الكافي لقراءة هذا المقال الصحفي؟؟؟؟ فقط ارفع ملف شارحاً ما تريد مع بعض الأمثلة

Try This code Option Explicit Sub Hide_then_Print() Dim LR% With Sheets("موازنة 2020") LR = .Cells(Rows.Count, 1).End(3).Row .Rows("1:3").Hidden = False .PageSetup.PrintArea = _ .Range("A1:F" & LR).Address .PrintPreview ' <<<==== Change to .PrintOut .Rows("1:3").Hidden = True End With End Sub

رائع استاذ حسين و لكن ما رأيك بهذا الكود (بدون أعمدة مساعدة) وحلقة تكرارية واحدة Sub Find_sum() Dim i As Long, a, b Dim Dic As Object Dim sh As Worksheet Set sh = Sheets("sheet1") sh.Range("J2").CurrentRegion.ClearContents a = sh.Cells(Rows.Count, 1).End(3).Row Set Dic = CreateObject("Scripting.Dictionary") For i = 2 To a If IsDate(sh.Cells(i, 1)) Then Dic(Format(sh.Cells(i, 1), "mmm")) = _ Dic(Format(sh.Cells(i, 1), "mmm")) + Val(sh.Cells(i, 2)) End If Next i If Dic.Count Then sh.Range("J2").Resize(Dic.Count) = _ Application.Transpose(Dic.keys) sh.Range("k2").Resize(Dic.Count) = _ Application.Transpose(Dic.Items) End If Set Dic = Nothing End Sub

جربي هذا الملف SUM_2.xlsm

تفضل Issa_New1.xlsm

Try This File Option Explicit Sub Regex_position(RG As Range, ByVal My_ExP As String) Dim rex As Object Dim Array_Pos() As Integer Dim Array_Mot() As String Dim Cnt% Dim My_Match, Sing_Match Dim K% Set rex = CreateObject("Vbscript.Regexp") With rex .Pattern = My_ExP: .ignorecase = True: .Global = True End With If rex.test(RG) Then K = RG.Row Set My_Match = rex.Execute(RG) Cnt = 0 For Each Sing_Match In My_Match ReDim Preserve Array_Pos(Cnt) ReDim Preserve Array_Mot(Cnt) Array_Pos(Cnt) = Val(Sing_Match.firstindex + 1) Array_Mot(Cnt) = Sing_Match Cnt = Cnt + 1 Next For Cnt = LBound(Array_Pos) To UBound(Array_Pos) With RG.Characters(Array_Pos(Cnt), Len(Array_Mot(Cnt))).Font .ColorIndex = Sheets("Formula"). _ Range("K1").Interior.ColorIndex .Size = 18: .Bold = True Sheets("Formula").Cells(K, "G") _ .Offset(, Cnt) = Array_Mot(Cnt) End With Next End If End Sub '++++++++++++++++++++++++++++++++++++ Sub Colorize_Please() reset_me Dim st, i%, lr lr = Sheets("Formula").Cells(Rows.Count, 5).End(3).Row st = "[A-Za-z]\d{2}" For i = 3 To lr Call Regex_position(Sheets("Formula").Range("E" & i), st) Next Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++++++++++++ Sub reset_me() Dim x With Sheets("Formula") x = .Cells(Rows.Count, 5).End(3).Row .Range("G3:N" & x).ClearContents With .Range("E3:E" & x).Font .ColorIndex = 1 .Bold = True: .Size = 14 End With End With End Sub osama.xlsm

تم التعديل كما تريد Sub fILTER_PLEASE() Dim D As Worksheet Dim m%, i%, Rod, RoH% Dim Ft_rg As Range Dim Ar_sh(), itm Dim Cret_range As Range Set D = Sheets("DATA") Set Ft_rg = D.Range("a5").CurrentRegion Rod = D.Cells(Rows.Count, 1).End(3).Row RoH = D.Cells(Rows.Count, "H").End(3).Row With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Application.DisplayAlerts = False For i = Sheets.Count To 1 Step -1 If Sheets(i).Name = "print" Or Sheets(i).Name = "DATA" Then Else Sheets(i).Delete End If Next Application.DisplayAlerts = True taj If Rod < 6 Or D.Cells(6, "H") = vbNullString Then GoTo Bay_Bay_Ya_Helween End If For i = RoH To 6 Step -1 If Not Application.Evaluate("ISREF('" & _ D.Range("H" & i) & "'!A1)") Then Sheets.Add(, after:=Sheets("DATA")).Name = _ D.Range("H" & i) End If Next For i = 1 To Sheets.Count If Sheets(i).Name = "print" Or Sheets(i).Name = "DATA" Then Else ReDim Preserve Ar_sh(m) Ar_sh(m) = Sheets(i).Name m = m + 1 End If Next For Each itm In Ar_sh With Sheets(itm) .Range("A:A").CurrentRegion.Clear .Range("C6") = D.Range("E5") .Range("D6") = D.Range("D5") .Range("E6") = D.Range("B5") .Range("F6") = D.Range("C5") .Range("B:B").EntireColumn.Hidden = True With .Range("A6:F6") .Font.Size = 16 .Font.Bold = True .Borders.LineStyle = 1 .HorizontalAlignment = 3 End With .Range("A:A").ColumnWidth = 10 .Range("C:C,E:E,F:F").ColumnWidth = 25 .Range("D:D").ColumnWidth = 30 .Range("H1") = D.Range("A5") .Range("H2") = .Name .Range("c2") = .Name With .Range("C2") .Font.Size = 18: .Font.Bold = True .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .HorizontalAlignment = 3 End With Set Cret_range = .Range("H1:h2") End With Ft_rg.AdvancedFilter 2, Cret_range, Sheets(itm).Range("C6:F6") With Sheets(itm) .Range("H1:H2").Clear m = .Cells(Rows.Count, 3).End(3).Row .Range("a7").Resize(m - 6) = _ Evaluate("ROW(1:" & m - 6 & ")") .Range("d" & m + 1) = "SUM" .Range("e" & m + 1).Resize(, 2).Formula = _ "=SUM(E7:E" & m & ")" .Range("D" & m + 1).Resize(, 3) _ .Interior.ColorIndex = 24 .Range("D" & m + 2) = "TOTAL" .Range("E" & m + 2) = _ .Range("E" & m + 1) - .Range("F" & m + 1) .Range("D" & m + 2).Resize(, 2) _ .Interior.ColorIndex = 35 With .Range("A7").Resize(m - 4, 6).SpecialCells(12) .Font.Size = 16 .Font.Bold = True .Borders.LineStyle = 1 .InsertIndent 1 .Columns(1).HorizontalAlignment = 3 End With End With Sheets(itm).Range("C6").CurrentRegion.Value = _ Sheets(itm).Range("C6").CurrentRegion.Value Next itm D.Select If D.FilterMode Then D.ShowAllData Bay_Bay_Ya_Helween: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With End Sub Issa_New.xlsm

هل من الممكن أن يتم عمل تلك القائمة اتوماتيك وليس بزر أمر (تم عمل ذلك اذا لم تظهر ثائمة الاسماء غادر الصفحة ثم عد اليها) 1- عودة الصف رقم 6 للعمل داخل الصفحة(DATA) لضرورة انشاء جدول للفلتر 2-الضفحة تدرج مباشر ة بعد الشيت DATA 3- هذا الماكرو يدرج صفحة باسم كل عميل مع بياناته بشكل مستقل ( الزر Sheet For Every one) 4-اذا زاد عدد العملاء الكود يتصرف بهذا الأمر Option Explicit Sub ADD_Sheet() Dim D As Worksheet Dim m%, i%, Rod, RoH% Dim Ft_rg As Range, Crit$ Dim Ar_sh(), itm Set D = Sheets("DATA") Set Ft_rg = D.Range("a5").CurrentRegion Rod = D.Cells(Rows.Count, 1).End(3).Row RoH = D.Cells(Rows.Count, "H").End(3).Row With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With If Rod < 6 Or D.Cells(6, "H") = vbNullString Then GoTo Bay_Bay_Ya_Helween End If For i = RoH To 6 Step -1 If Not Application.Evaluate("ISREF('" & _ D.Range("H" & i) & "'!A1)") Then Sheets.Add(, after:=Sheets("DATA")).Name = _ D.Range("H" & i) End If Next D.AutoFilterMode = 0 For i = 1 To Sheets.Count If Sheets(i).Name = "print" Or Sheets(i).Name = "DATA" Then Else ReDim Preserve Ar_sh(m) Ar_sh(m) = Sheets(i).Name m = m + 1 End If Next For Each itm In Ar_sh Sheets(itm).Range("A6").CurrentRegion.Clear Ft_rg.AutoFilter 1, itm Ft_rg.SpecialCells(12).Copy Sheets(itm).Range("A6").PasteSpecial (8) Sheets(itm).Range("A6").PasteSpecial Sheets(itm).Range("H6") = "Account Of" & Space(3) & itm _ Next itm D.Select D.AutoFilterMode = 0 Bay_Bay_Ya_Helween: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub Issa_Macro_New.xlsm

عندي كل شيء على ما يرام (الصورة توضح ذلك) لتغيير عامود الجمع استبدل Bx بــــــ BN (الصورة الثاتية)

جرب هذا الملف Mohamed D.xlsx

Try This file Hashem.xlsx

جرب هذا الكود (لا تنس اضافة صف فارغ تماماً في كل صفحة الصف رقم 6 /مخفي لعدم الكتابة فيه عن طريق الخطأ) Option Explicit Sub taj() Dim P As Worksheet Dim D As Worksheet Dim m%, i%, Rod, Rop% Dim Obj As Object Set D = Sheets("DATA") Set P = Sheets("print") Set Obj = CreateObject("System.Collections.ArrayList") Rod = D.Cells(Rows.Count, 1).End(3).Row Rop = P.Cells(Rows.Count, 1).End(3).Row If Rod < 7 Then Exit Sub D.Cells(7, "H").Resize(Rod).ClearContents With Obj For i = 7 To Rod If Not .contains(D.Cells(i, 1).Value) And _ D.Cells(i, 1) <> vbNullString Then .Add D.Cells(i, 1).Value End If Next i .Sort D.Cells(7, "H").Resize(.Count) = _ Application.Transpose(.ToArray) End With With D.Cells(3, "D").Validation .Delete .Add 3, Formula1:=Join(Obj.ToArray, ",") End With With P.Cells(3, "B").Validation .Delete .Add 3, Formula1:=Join(Obj.ToArray, ",") End With Set Obj = Nothing End Sub الملف مرفق Issa_Macro.xlsm

يا اخي او ان تشرح بالتفصيل ما تريد او أعتذر انا عن المساعدة تساؤلات 1-عمل قائمة منسدلة في الخلية D3 تحتوى أسماء العملاء (في اي صفحة تريد ذلك؟؟؟؟) 2- عمل قائمة بأسماء الحسابات الموجودة في العمود A وتكون في العمود H (في اي صفحة تريد ذلك؟؟؟؟) 3-الخلية F3 في TextBox1 و وضع محتوى الخلية G3 في TextBox2 (لا أري اي TextBox أو 2TextBox في الملف ) 4- الملفي يجب ان يكون كما في المرفق ( و عندما يكتمل الملف لوّن ما تشاء و نسّق الالوان كما تريد) 5- كما ترى بعد ازالة النتسيقات انخفض حجم الملف من 255 كيلو الى 35 فقط ) حوالي 8 مرات Issa_Hatem.xlsm

تم التعديل كما تريد 1-تحنار الفضل من الخلية Bx6 ثم تضغط على الزر Fasl 2- الماكرو القديم ما زال يعمل (للفصلين معاً ) الزر ALL الماكرو الجديد Option Explicit Sub checK_up_By_Fasl() Dim F As Worksheet Dim Arr(), Itm, My_sum Dim m%, K%, i%, Ro%, y% Dim arr_madda() Const a = 4 Const b = 1 Dim Nb% Dim Res(), XX%, MY_text$ Dim Txt$: Txt = "المجمــــــوع الكلـــــــي" Set F = Sheets("F1") Ro = F.Cells(Rows.Count, 3).End(3).Row If Ro < 12 Then Exit Sub F.Cells(12, "H").Resize(Ro - 11, 49).Interior.ColorIndex = xlNone F.Cells(12, "Ca").Resize(Ro - 11, 49).ClearContents F.Cells(12, "Bx").Resize(Ro - 11).ClearContents Select Case F.Range("Bx6") Case "الأول": Nb = a Case "الثاني": Nb = b End Select For K = 8 To 55 If F.Cells(7, K) = Txt Then ReDim Preserve Arr(m): Arr(m) = K - Nb: m = m + 1 End If Next m = 0 For K = 8 To 50 If F.Cells(6, K) <> "" Then ReDim Preserve arr_madda(m) arr_madda(m) = F.Cells(6, K) & " / " & F.Range("Bx6") m = m + 1 End If Next For i = 12 To Ro y = 0 For Each Itm In Arr My_sum = My_sum + F.Cells(i, Itm) If F.Cells(i, Itm) < F.Cells(10, Itm) / 2 Then F.Cells(i, Itm).Interior.ColorIndex = 6 ReDim Preserve Res(y) Select Case Itm Case Is <= 13: Res(y) = arr_madda(0) Case Is <= 20: Res(y) = arr_madda(1) Case Is <= 27: Res(y) = arr_madda(2) Case Is <= 34: Res(y) = arr_madda(3) Case Is <= 41: Res(y) = arr_madda(4) Case Is <= 48: Res(y) = arr_madda(5) Case Is <= 55: Res(y) = arr_madda(6) End Select y = y + 1 End If Next Itm If y > 1 Then F.Cells(i, "Ca").Resize(, y) = Res Else F.Cells(i, "Bx") = My_sum End If Erase Res: y = 0: My_sum = 0 Next i End Sub الملف من جديد Khiri_ali_New.xlsm

قلت ملف جديد بدون اي ماكرو و بدون تنسيقات مع شرح ما تريد بالتغصيل الملف لا يفتح عندي بالشكل المطلوب

ارفع ملف جديد بدون اي ماكرو و بدون تنسيقات مع شرح ما تريد بالتغصيل

سبب بطء البرنامج هو كثرة الألوان والتنسيفات صورة عن صفحة واحدة من الملف تظهر ذلك ( جميع الصفحات بنفس النتيجة)

با اخي 7 مواد ضرب 2 فصول يعني 14 نتيجة يعني 14 عامود (انت تريد تنيجة لكل فضل من الفصول)

انت وضعت 7 أعمدة لمواد الرسوب من العامود 79 الى العامود 85 (ممكن ان بكون عدد هذه المواد اكثر) لذلك وضعت انا اعمدة زيادة (خاصة انه لكل مادة اكثر من فصل واحد) اما ترتيب المواد ذلك يكون حسب ورودها في الجدول (اذا كانت اول مادة رسوب للطالب (فلان) هي الرياضيات مثلاً فانك تجدها الأولى في الجدول (في الصف) الذي يخصه النسبة لم اتدخل بها لانها مجرد معادلة بسيطة

جرب هذا الماكرو Option Explicit Sub checK_up() Dim F As Worksheet Dim Arr(), Itm, My_sum Dim m%, K%, i%, Ro%, y% Dim arr_madda() Dim Res(), XX%, MY_text$ Dim Txt$: Txt = "المجمــــــــــوع" Set F = Sheets("F1") Ro = F.Cells(Rows.Count, 3).End(3).Row If Ro < 12 Then Exit Sub F.Cells(12, "H").Resize(Ro - 11, 49).Interior.ColorIndex = xlNone F.Cells(12, "Ca").Resize(Ro - 11, 49).ClearContents F.Cells(12, "Bx").Resize(Ro - 11).ClearContents For K = 8 To 55: If F.Cells(9, K) = Txt Then ReDim Preserve Arr(m): Arr(m) = K: m = m + 1 End If Next m = 0 For K = 8 To 50 If F.Cells(6, K) <> "" Then ReDim Preserve arr_madda(m): arr_madda(m) = F.Cells(6, K) m = m + 1 End If Next For i = 12 To Ro y = 0 For Each Itm In Arr My_sum = My_sum + F.Cells(i, Itm) If F.Cells(i, Itm) < F.Cells(10, Itm) / 2 Then F.Cells(i, Itm).Interior.ColorIndex = 6 ReDim Preserve Res(y) Select Case Itm Case Is <= 13: Res(y) = arr_madda(0) Case Is <= 20: Res(y) = arr_madda(1) Case Is <= 27: Res(y) = arr_madda(2) Case Is <= 34: Res(y) = arr_madda(3) Case Is <= 41: Res(y) = arr_madda(4) Case Is <= 48: Res(y) = arr_madda(5) Case Is <= 55: Res(y) = arr_madda(6) End Select y = y + 1 End If Next Itm If y > 1 Then F.Cells(i, "Ca").Resize(, y) = Res Else F.Cells(i, "Bx") = My_sum End If Erase Res: y = 0: My_sum = 0 Next i End Sub الملف مرفق Khiri_ali.xlsm

المشكلة عندك في الجهاز يجب تغيير نظام التاريخ فيه الى yyyy/mm/dd