محمد هشام.

السلام عليكم ورحمة الله نعالى وبركاته بعد ادن الاستاد أ / محمد صالح بالنسبة لاظهار بيانات اليوم فقط تفضل جرب اخي Private Sub UserForm_Initialize() Dim f As Worksheet: Set f = Sheets("ورقة1") Set d = CreateObject("scripting.dictionary") Col = f.Range("B4:E" & f.[B65000].End(xlUp).Row).Value Rng = UBound(Col, 2) With Me.ListView1 .Gridlines = True .FullRowSelect = True .View = lvwReport .ColumnHeaders.Add , , "code", 0 .ColumnHeaders.Add , , "م", 30, lvwColumnCenter .ColumnHeaders.Add , , "التاريخ", 80, lvwColumnCenter .ColumnHeaders.Add , , "اسم العميل", 120, lvwColumnCenter .ColumnHeaders.Add , , "الرقم ", 60, lvwColumnCenter Cpt = 1 ' من بداية الجدول ' For i = 1 To UBound(Col) For i = UBound(Col) - 19 To UBound(Col) ' تحديد اخر 20 صف If Col(i, 2) = Date Then ' شرط تاريخ اليوم .ListItems.Add , , Col(i, 1) For k = 1 To Rng .ListItems(Cpt).ListSubItems.Add , , Col(i, k) Next k Cpt = Cpt + 1 End If Next i End With End Sub listview 2.xlsm

العفو اخي يسعدني انني استطعت مساعدتك بالتوفيق.

Sub Print_certificates() Dim wb As Workbook, wsData As Worksheet, wsDest As Worksheet Dim fRow, fName As String, MyRng As Range, FndRng As Range Dim Cpt As Range, Linge As String, myValue As String, Question As Integer Set wb = ThisWorkbook: Set wsData = wb.Sheets("Mark All"): Set wsDest = wb.Sheets("Moncer") Set MyRng = wsDest.[A3:I46] myValue = "توقيع ولي الأمر:" Question = MsgBox("طباعة شهادات جميع الطلاب ؟", vbYesNo + vbInformation + vbDefaultButton2, "...تأكيد") If Question = vbYes Then If Len(wsDest.[J1].Value) = 0 Then: MsgBox "المرجوا إدخال إسم الملف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "إنتباه": Exit Sub Application.ScreenUpdating = False Application.DisplayAlerts = False With model .Visible = xlSheetVisible: .Cells.Clear: .ResetAllPageBreaks End With On Error Resume Next With ActiveWorkbook fFolder = .path & Application.PathSeparator & "شهادات الطلاب" & Application.PathSeparator If Len(Dir(fFolder, vbDirectory)) = 0 Then End If MkDir fFolder On Error GoTo 0 For cList = 9 To wsData.Cells(Rows.Count, "B").End(xlUp).Row cName = wsData.Cells(cList, "B"): wsDest.[B8] = cName wsDest.[T1] = cName: fName = wsDest.[J1] MyRng.Copy With model.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths Application.CutCopyMode = False End With Next cList End With With model fRow = .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set FndRng = .Range("A17:A" & fRow) Set Cpt = FndRng.Find(What:=myValue, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext) If Not Cpt Is Nothing Then: Linge = Cpt.Address Do If Not Cpt Is Nothing Then: Cpt.RowHeight = 21: Cpt.Offset(2).PageBreak = xlPageBreakManual: Cpt.Offset(-1).RowHeight = 36 Set Cpt = FndRng.FindNext(Cpt) If Cpt Is Nothing Then: Exit Do If Cpt.Address = Linge Then: Exit Do Loop model.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fFolder & fName & ".pdf" 'قم بتفعيل هداالسطر في حالة الرغبة بطباعة الشواهد ' .PrintOut .Visible = xlSheetVeryHidden End With Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox fFolder & "" & fName, vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, " :تم حفظ شهادات الطلاب بنجاج في" End If End Sub Test13.xlsm

للأسف أخي طلبك غير واضح ماذا تقصد بالحفظ هل حفظ الشيت او المصنف وما هو التنسيق المطلوب. وما هو مكان الحفظ وهل يتم تنفيذ المطلوب بمجرد تغيير اسم اليوم من القائمة أو عند الظغط على زر معين. كل هذا يجب توضيحه لنتمكن من فهم طلبك ومحاولة مساعدتك

ممكن ارفاق صورة مع توضيح مكان الخطأ لأنني قمت بتجربة الكود ولاحظت أنه يقوم باستخراج لكل طالب علامات مختلفة على حسب ما هو موجود في الملف!!!! في حالة الرغبة في استخراج ملف Pdf واحد لجميع الطلاب ماهو إسم الملف المقترح؟ وهل هناك مانع لاظافة ورقة أخرى على الملف ام لا؟ كما يفضل أخي الكريم بما أنك توصلت لحل المشكلة الرئيسة. إغلاق الموضوع ومحاولة فتح موضوع آخر بطلبك الجديد تفاديا للخلط .ربما يستطيع أحد الإخوة الأساتذة مساعدتك

طلبك غير واضح الكود يقوم بحفظ شهادات جميع الطلاب للفصل والتقويم المحدد ووضعها في مجلد في نفس مسار الملف ولطباعتها قم بتفعيله هذا السطر 'wsDest.PrintOut اما بالنسبة لدمجها في ملف Pdf واحد يتعين عليك أولا نسخ الشهادات إلى ورقة أخرى .وبعد ذلك يمكنك تحديد الحفظ او الطباعة بالطريقة التي تناسبك

Sub Print_certificates() Dim wb As Workbook, wsData As Worksheet, wsDest As Worksheet Set wb = ThisWorkbook: Set wsData = wb.Sheets("Mark All"): Set wsDest = wb.Sheets("Moncer") Application.ScreenUpdating = False On Error Resume Next With ActiveWorkbook fPath = .path & Application.PathSeparator & "شهادات الطلاب" & Application.PathSeparator If Len(Dir(fPath, vbDirectory)) = 0 Then End If MkDir fPath For List = 9 To wsData.Cells(Rows.Count, "B").End(xlUp).Row F = wsData.Cells(List, "B") wsDest.[B8] = F: wsDest.[T1] = F wsDest.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & F & ".pdf" 'wsDest.PrintOut Next List On Error GoTo 0 End With End Sub Test12.xlsm

أعتذر على التأخير في الرد بسبب ظروف العمل على العموم تفضل أخي تم إنجاز المطلوب بالمعادلات لصعوبة التعامل مع كثرة الخلايا المدمجة داخل الأكواد مع بعض التعديلات البسيطة للحصول على النتائج بشكل أدق. Test11.xlsm

هل من الممكن تزويدنا بالنتيجة المتوقعة للطالب مجمد على ورقة Moncer

وعليكم السلام ورحمة الله تعالى وبركاته اخي حاول تنظيم ملفك أكثر مع ذكر أسماء أوراق العمل المرغوب الاشتغال عليها مع التأكد من توحيد نطاقات الأعمدة على كل الشيتات . ومن الأفضل الاشتغال على جداول ....

حل اخر يغنيك عن كتابة الاكواد في الورقة "الورقة 1" ، ضع أسماء النماذج في العمود A وفي العمود B وقت كل نموذج ، كما هو موضح في المثال التالي: 2) قم بتشغيل هذا الماكرو: 😁 Sub View_User() Dim uForm As Object Dim i As Long Dim MyRng As Variant Dim Nameform As String On Error Resume Next MyRng = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("B" & Rows.Count).End(3)) Application.Visible = False For i = 1 To UBound(MyRng) Nameform = MyRng(i, 1) Set uForm = CallByName(UserForms, "Add", VbMethod, Nameform) DoEvents uForm.Show 0 Application.Wait Now + TimeValue("00:00:" & MyRng(i, 2)) DoEvents Unload uForm Next Application.Visible = True On Error GoTo 0 End Sub اليك الملف للفائدة تجربة 4.xlsm

اليك اخي طريقة اسرع في حالة وجود عدد كبير من الصفوف المرحلة الكود اطول لاكن اسرع بكثير من الاول 😄يمكنك ترحيل 400 صف في 2 ثواني تقريبا Sub Copy_Reports2() '''''''''''''''''' New additions to speed up code execution '""""""""""""""""""" Dim ws As Worksheet: Set ws = Sheets("البيانات") Dim wsDest As Worksheet: Set wsDest = Worksheets("تقسيم") Dim sMsg As String, rHeaders As Range, ligne As Range, t1 As Range, t2 As Range Dim LastRow&, Titles&, Cpt&, lastCol&, col&, rngCell, r&, c As Range, Réf&, N& temps = Timer With Application .EnableEvents = False .ScreenUpdating = False End With limite = ws.Evaluate("SUM(0+(A4:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row & "<>""""))") Set rHeaders = ws.Range("A1:P3") Set ligne = wsDest.[A5] wsDest.Cells.Clear For x = 4 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If ws.Range("A" & x) <> "" Then: Rng = ws.Range("A4:P" & x) début = 1: TailleBloc = 10: décal = 0: Next Do While début <= UBound(Rng) fin = début + TailleBloc - 1: If fin > UBound(Rng) Then fin = UBound(Rng) b = Application.Index(Rng, Evaluate("Row(" & début & ":" & fin & ")"), Application.Transpose(Evaluate("Row(1:" & UBound(Rng, 2) & ")"))) If ligne = 0 Then wsDest.Range("a" & Rows.Count).End(xlUp).Offset(3).Resize(UBound(b), UBound(b, 2)) = b Else Réf = wsDest.Columns("A:A").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row wsDest.Range("A" & Réf + 6).Resize(UBound(b), UBound(b, 2)) = b End If décal = décal + UBound(Rng, 2) + 1: début = fin + 1 Loop wsDest.Activate With wsDest.Cells .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: ActiveWindow.ScrollRow = 1: ActiveWindow.ScrollColumn = 1 .RowHeight = 40: .Columns(10).ColumnWidth = 23: .Columns(15).ColumnWidth = 16: .Font.Size = 16: .Font.Name = "Arial" End With LastRow = wsDest.Range("A:P").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = wsDest.Range("A3 :P" & LastRow) rngCell.Borders.LineStyle = xlNone For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Cpt = 14 N = 1 For Titles = 1 To LastRow Step Cpt If wsDest.Cells(Titles, "A").Offset(5, 0) <> "" Then rHeaders.Copy wsDest.Cells(Titles, 1).Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False Set t1 = wsDest.Cells(Titles, "B").Offset(13, 0) Set t2 = wsDest.Cells(Titles, "C").Offset(13, 0) t1.Interior.Color = RGB(204, 255, 255): t1.Value = " رقم القائمة" t2.Value = N: t2.Interior.Color = RGB(204, 255, 255) Titles = Titles + 1 N = N + 1 End If Next Titles Application.CutCopyMode = False With wsDest For i = 3 To LastRow On Error Resume Next If wsDest.Cells(i, "M") Like "الكمية المحتسبة" And wsDest.Cells(i, "M").Offset(10, 0) <> "" Then 'تلوين الخلفية wsDest.Cells(i, "j").Offset(11, 0).Resize(, 7).Interior.Color = vbYellow: wsDest.Cells(i, "J").Offset(11, 0).Value = "المجموع" wsDest.Cells(i, "M").Interior.Color = vbYellow: wsDest.Cells(i, "O").Interior.Color = vbYellow 'الكمية المحتسبة wsDest.Cells(i, "M").Offset(11, 0) = WorksheetFunction.Sum _ (Range(Cells(i, "M").Offset(1, 0), Cells(i, "M").Offset(10, 0))) 'المبلغ الكلي wsDest.Cells(i, "O").Offset(11, 0) = WorksheetFunction.Sum _ (Range(Cells(i, "O").Offset(1, 0), Cells(i, "O").Offset(10, 0))) ' النقص wsDest.Cells(i, "P").Offset(11, 0) = WorksheetFunction.Sum _ (Range(Cells(i, "P").Offset(1, 0), Cells(i, "P").Offset(10, 0))) End If Next i [A3].Select End With On Error GoTo 0 sMsg = " تم ترحيل" & " " & limite & " مستند " & " " & "بنجاح" MsgBox sMsg & vbCrLf & vbCrLf & " " & " " & "تم تنفيد الكود في: " & Format(Timer - temps, "0.0000"), Exclamation, "اوفيسنا" With Application .EnableEvents = True .ScreenUpdating = True End With End Sub اضافة رقم القائمة 2.xlsm

تفضل اخي =SUM(COUNTIF(INDIRECT({"E5";"P5";"L7";"B13";"N14";"G16"});">0")) جمع خلاياء.xlsx

تفضل جرب المعادلات التالية ربما هدا ما تقصده test.xlsx

ممكن اخي توضح طلبك اكثر ماهي البيانات المرغوب نسخها والى اين

لا أعلم لماذا أنت مصمم على عدم رفع ملف للاشتغال عليه . ربما بالنسبة لك الأمر بسيط كما ذكرت من قبل لاكن الاشتغال على التخمين مجرد إهدار للوقت . وإحتمالية حصولك على الجواب الصحيح تبقى ظئيلة

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد أ / محمد صالح وبما انه جاء في طلبك انك ترغب باستخدام الاكواد لابأس في اثراء الموضوع بالكود التالي Sub Extract_days() Dim WSData As Worksheet Dim rng As Range, strDays As String Dim Col As Variant, arDays As Variant Dim iDays As Long, lr As Long, i As Long Set WSData = Worksheets("ورقة2") Application.ScreenUpdating = False WSData.Range("E2", Range("E" & Rows.Count).End(3)).ClearContents With WSData lr = .Range("D" & Rows.Count).End(xlUp).Row Set rng = .Range("B2:G" & lr) Col = rng.Value End With On Error Resume Next For i = 1 To UBound(Col) strDays = "" arDays = Split(Col(i, 3), "-") For iDays = 0 To UBound(arDays) strDays = strDays & "-" & Format(DateSerial(Col(i, 6), Col(i, 5), arDays(iDays)), "dddd") Next iDays Col(i, 4) = Right(strDays, Len(strDays) - 1) Next i On Error GoTo 0 With rng.Columns(4) .Value = Application.Index(Col, 0, 4) '.Columns.AutoFit End With Application.ScreenUpdating = True End Sub الغياب2.xlsm

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

نعم اخي يمكنك دالك بتعطيل هدا الصف فقط f.UsedRange = f.UsedRange.Value رغم انني عند كتابة الكود لاحظت ان الفكرة ربما لم كانت على يوزرفورم سوف تكون مميزة (لانني دائما عند الاشتغال على اي ملف اطمح الى تقديم الافضل رغم عدم طلبه ) لهدا قررت بعدما طلبت مني التعديل بانشاءه ربما يساعدك على الاشتغال على الملف بشكل افضل مع البقاء على الكود الاول ليبقى لك اختيار ما يناسبك طبعا اليك شرح الكود الاول ربما تحتاج يوما الا تعديل شيء ما Sub Créer_des_feuilles() Dim rng As Range, dico As Range, Cell As Range Dim arr(1 To 2) As String, f As Worksheet ' رسالة تنبيه عند كتابة اسم غير موجود على المصنف arr(1) = "المرجوا التحقق من إسم ورقة العمل" ' رسالة بنجاح النسخ تتظمن اسماء الاوراق الجديدة arr(2) = "تم نسخ اوراق العمل بنجاح" On Error GoTo Errorhandling NameWS = InputBox("أدخل إسم ورقة العمل المراد نسخها ", " نسخ ورقة العمل") ' التحقق من اسم ورقة العمل المراد نسخها If Evaluate("ISREF('" & NameWS & "'!A1)") Then Set rng = Application.InputBox(Prompt:=" حدد نطاق أسماء أوراق العمل: ", _ Title:="تسمية أوراق العمل", _ Default:=Selection.Address, Type:=8) For Each dico In rng ' تجاهل الفراغات اثناء التحديد If dico <> Empty Then Application.ScreenUpdating = False ' التحقق من وجود اسم الشيت مسبقا على المصنف If Not Evaluate("ISREF('" & dico & "'!A1)") Then Sheets(NameWS).Copy after:=ActiveWorkbook.Sheets(Worksheets.Count) Set f = ActiveSheet 'تسمية اوراق العمل f.Name = dico ' حدف الازرار f.DrawingObjects.Delete 'التحويل الى قيم ' f.UsedRange = f.UsedRange.Value ' تخزين اسماء الشيتات الجديدة For Each Cell In dico ws = ws & vbCrLf & Cell.Value Next Cell End If End If Next dico Application.ScreenUpdating = True MsgBox arr(2) & vbCrLf & ws, vbOKOnly, "تعليمات:" Else MsgBox arr(1), vbCritical, "إنتباه:" End If Errorhandling: End Sub تفضل اخي في انتظارك بعد تجربة الملف وسوف نكون سعداء دائما بمساعدتك Create-Sheets_User.xlsb

العفو اخي يسعدنا اننا استطعنا مساعدتك

تفضل اخي اليك طلبك يمكنك تطويعه على حسب احتياجاتك Sub Créer_des_feuilles() Dim rng As Range, dico As Range, Cell As Range Dim arr(1 To 2) As String, f As Worksheet arr(1) = "المرجوا التحقق من إسم ورقة العمل" arr(2) = "تم نسخ اوراق العمل بنجاح" On Error GoTo Errorhandling NameWS = InputBox("أدخل إسم ورقة العمل المراد نسخها ", " نسخ ورقة العمل") If Evaluate("ISREF('" & NameWS & "'!A1)") Then Set rng = Application.InputBox(Prompt:=" حدد نطاق أسماء أوراق العمل: ", _ Title:="تسمية أوراق العمل", _ Default:=Selection.Address, Type:=8) For Each dico In rng If dico <> Empty Then Application.ScreenUpdating = False If Not Evaluate("ISREF('" & dico & "'!A1)") Then Sheets(NameWS).Copy After:=ActiveWorkbook.Sheets(Worksheets.Count) Set f = ActiveSheet: f.Name = dico: f.DrawingObjects.Delete: f.UsedRange = f.UsedRange.Value For Each Cell In dico ws = ws & vbCrLf & Cell.Value Next Cell End If End If Next dico Application.ScreenUpdating = True MsgBox arr(2) & vbCrLf & ws, vbOKOnly, "تعليمات:" Else MsgBox arr(1), vbCritical, "إنتباه:" End If Errorhandling: End Sub Create-Sheets.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد محمد صالح اليك حلول اخرى =INDEX($B$2:$D$6, MATCH(A10,$A$2:$A$6,0), MATCH(B10, $B$1:$D$1, 0)) او =HLOOKUP(I12,$H$1:$K$6,MATCH(H12,$H$1:$H$6,0),0) اوفيسنا.xlsx

أخي وضح طلبك أكثر. هل اسم الشيت الذي سيتم إدخاله هو اسم الشيت المراد نسخه او هو الاسم المفروض تسمية الأوراق الجديدة به. هل تريد انشاء أوراق جديدة باسم الخلايا التي تم تحديدها او انشاء نسخة من ورقة معينة !!!!!

اخي سعد صفحة المطور ليس لها علاقة بملف او مصنف معين.هي إعدادات خاصة بنسخة الأوفيس. يتم تحديدها من طرفك بالشكل الذي تريد. ربما وبدون قصد تم حذف او إضافة نافذة معينة أو شيء من هذا القبيل من المطور واصبح بشكل انت غير متعود عليه. كما سميتها انت باللخبطة. اسهل طريقة بالنسبة لك هي إعادة نسخة الأوفيس للوضع الافتراضي

Sub test1() Dim WS As Worksheet: Set WS = ActiveSheet '<<<---- Worksheets("27-10-2023الى2-11-2023") 'اسم ورقة العمل Dim lastrow As Long, ligne As Range, search As Rang Set ligne = [U4] '<<<----' خلية اللصق Set search = [L19] '<<<-- اي القيمة التي تم جلبها من الخلية '<<<---اول تاريخ على الجدول ("A4") ' '("U")' تحديد اخر خلية بها بيانات من عمود lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1 ' لمنع التكرار '*********************** '("U") 'التحقق من وجود نفس تاريخ المدفوعات مسبقا في عمود ' ' في حالة وجوده يتم ايقاف تنفيد الكود مع رسالة اشعار If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub A = [L19:Q51].Value ''<<<----'نطاق البيانات المرحلة If ligne = 0 Then ' '<<<----التحقق من عدم وجود قيمة في خلية اللصق ' U4'في حالة فراغها يتم لصق البيانات ابتداءا من الخلية [U4].Resize(UBound(A), UBound(A, 2)).Value2 = A Else ' U ' في حالةوجودقيمة يتم لصق البيانات بعد اخر صف به بيانات من عمود Range("U" & lastrow).Resize(UBound(A), UBound(A, 2)).Value2 = A End If MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation End Sub