كل الانشطه

اخى محمد هشام كل الشكر والتقدير لك اخى الكريم جارى التجربه ولكن مجهود كبير تشكر عليه جزاك الله خيرا اخى محمد هشام كل الشكر والتقدير لك اخى الكريم جارى التجربه ولكن مجهود كبير تشكر عليه جزاك الله خيرا

السلام عليكم ورحمة الله وبركاته اليك ما طلبت Sub ExportCertificatesToSinglePDF() Dim lr As Long, i As Long, pageCount As Long Dim pdfPath As String, wsMain As Worksheet, tempWS As Worksheet Dim tempSheetNames As Collection Dim sh As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False Set wsMain = ThisWorkbook.Sheets("معلمين") Set tempSheetNames = New Collection wsMain.Range("m2").FormulaR1C1 = "=COUNTA('جدول عام'!R6C1:R22C1)" lr = wsMain.Range("m2").Value i = 1 pageCount = 1 Do Until i > lr wsMain.Range("m2").Value = i wsMain.Copy After:=Sheets(Sheets.Count) Set tempWS = ActiveSheet tempWS.Name = "Temp_" & pageCount tempWS.PageSetup.PrintArea = "$A$1:$i$37" tempSheetNames.Add tempWS.Name i = i + 3 pageCount = pageCount + 1 Loop pdfPath = ThisWorkbook.Path & "\الشهادات.pdf" Dim wsArray() As Variant ReDim wsArray(1 To tempSheetNames.Count) For i = 1 To tempSheetNames.Count wsArray(i) = tempSheetNames(i) Next i ThisWorkbook.Sheets(wsArray).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath For i = 1 To tempSheetNames.Count Application.DisplayAlerts = False ThisWorkbook.Sheets(tempSheetNames(i)).Delete Application.DisplayAlerts = True Next i wsMain.Select wsMain.Range("m2").Value = 1 Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "تم حفظ الشهادات في ملف PDF بنجاح!", vbInformation, "تم الحفظ" End Sub تحويل الشهادات الى pdf.xlsm

اللهم إنا نسألك بأسمائك الحسنى وبصفاتك العلا وبرحمتك التي وسعت كلّ شيء، أن تمنّ عليه بالشفاء العاجل، وألّا تدع فيه جرحاً إلّا داويته، ولا ألماً إلا سكنته، ولا مرضاً إلا شفيته، وألبسه ثوب الصحة والعافية عاجلاً غير آجل، وشافِه وعافِه واعف عنه، واشمله بعطفك ومغفرتك، وتولّه برحمتك يا أرحم الراحمين.

Up

أكرمكم وأعزكم الله أستاذنا هو المطلوب وزيادة والله جزاكم الله كل الخير

آمل أن يكون هذا ما تريده فعلاً أخي احمد ، أكرمك الله على ما دعيت لي به ، وفتح الله عليكم من علمه ورزقه .. كل الإحترام والتقدير لشخصكم الكريم ..

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

جرب هذه النسخة ، وطابق النتائج . فكرة توزيع تلقائي لمستويين (4).mdb

تمام .. جاري التعديل

ما أقصده هو أنني فتحت جدول الشفوي وأريد توزيع طلاب الصف السادس بالمدرسة رقم 40 (الإجمالي الموجود هو 268 طالب) والذين تم تقسيمهم في جدول الشفوي على 13 دفعة كما في الصورة فسيكون التوزيع الدفعة الأولى 70 صباحي تم الحصول عليهم من (دفعة 1 / دفعة 2 / دفعة 3 / دفعة 4) الدفعة الثانية 60 مسائي تم الحصول عليهم من (باقي دفعة 4 / دفعة 5 / دفعة 6) الدفعة الثالثة 70 صباحي تم الحصول عليهم من (باقي دفعة 6 / دفعة 7 / دفعة 8 / دفعة 9 / دفعة 10) الدفعة الرابعة 60 مسائي تم الحصول عليهم من (باقي دفعة 10 / دفعة 11 / دفعة 12) الدفعة الخامسة 8 (المتبقيين من الصف السادس) صباحي تم الحصول عليهم من (باقي دفعة 12 / دفعة 13) مع خالص تقديري

بحاجة الى توضيح أكثر ، حتى أوجه التعديل الصحيح .

الله الله الله أستاذنا الكبير التوزيع أكثر من رائع وسليم 100 % هي ملاحظة صغيرة جدا جدا وهي أن حقل Noot أو الدفعات .. مطلوب به أن يسجل فيه فقط لا غير الدفعات التي كونت العدد 70 في الصباحي أو الدفعات التي كونت العدد 60 في المسائي وعند ترحيل باقي دفعة (من مجموعة لمجموعة) يتم ذكرها في قرين كل من المجموعتين والف شكر لسعادتك وسلمت يمينك ؛؛؛

كيف احدد اذا كان للمعلم لجنة تصحيح هل كتابة correction1 Correction2 Correction3 بهذا الترتيب

ممكن استاذ تقلي نوعية الخط الذي كتبت به الصورة نقصد باللون الاسود

اللهم اشفي كل مريض عاجل غير اجل

Up

ادن لنجرب طريقة أخرى Option Explicit Sub Testxlsb() Dim xPath As String, n As Double Dim startTime As Double, xList As String Dim sCount As Long, confirm As VbMsgBoxResult xPath = "D:\" xList = "" With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual startTime = Timer tmps xPath, xList If xList = "" Then MsgBox "لم يتم العثور على أي ملفات بامتداد xlsb في " & xPath Else sCount = UBound(Split(Trim(xList), vbCrLf)) confirm = MsgBox("تم العثور على " & sCount & " ملف بامتداد xlsb " & vbCrLf & _ "هل تريد حدفها ونقلها إلى مجلد الملفات المحدوفة ؟", vbYesNo + vbQuestion) If confirm = vbYes Then tbl xPath, xList Snames xList MsgBox "تم الحذف وحفظ أسماء الملفات في C:\الملفات المحدوفة\filName.txt" Else MsgBox "تم إلغاء العملية لم يتم حذف أي ملفات" End If End If .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With n = Timer - startTime MsgBox "تم تنفيذ العملية في: " & Format(n, "0.00") & " ثانية" End Sub Sub tmps(ByVal xPath As String, ByRef xList As String) Dim fso As Object, Folder As Object, file As Object, sFiles As Object Set fso = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set Folder = fso.GetFolder(xPath) If Folder Is Nothing Then Exit Sub On Error GoTo 0 If Not Folder Is Nothing Then On Error Resume Next For Each file In Folder.Files If (file.Attributes And 2) = 0 And (file.Attributes And 4) = 0 Then If LCase(fso.GetExtensionName(file.Name)) = "xlsb" Then xList = xList & file.Path & vbCrLf End If End If Next On Error GoTo 0 On Error Resume Next For Each sFiles In Folder.sFiless tmps sFiles.Path, xList Next On Error GoTo 0 End If End Sub Sub tbl(ByVal xPath As String, ByRef xList As String) Dim fso As Object, Folder As Object, file As Object, sFiles As Object Dim CntFile As String, r As String, ky As Integer CntFile = "C:\الملفات المحدوفة\DeletedXLSB\" Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists("C:\الملفات المحدوفة\") Then fso.CreateFolder ("C:\الملفات المحدوفة\") If Not fso.FolderExists(CntFile) Then fso.CreateFolder (CntFile) On Error Resume Next Set Folder = fso.GetFolder(xPath) If Folder Is Nothing Then Exit Sub On Error GoTo 0 On Error Resume Next For Each file In Folder.Files If Err.Number = 0 Then If (file.Attributes And 2) = 0 And (file.Attributes And 4) = 0 Then If LCase(fso.GetExtensionName(file.Name)) = "xlsb" Then r = CntFile & fso.GetFileName(file.Path) ky = 1 While fso.FileExists(r) r = CntFile & "Copy_" & ky & "_" & fso.GetFileName(file.Path) ky = ky + 1 Wend file.Move r End If End If End If Err.Clear Next For Each sFiles In Folder.sFiless tbl sFiles.Path, xList Next On Error GoTo 0 End Sub Sub Snames(xList As String) Dim fileNum As Integer fileNum = FreeFile On Error Resume Next Open "C:\الملفات المحدوفة\filName.txt" For Output As #fileNum Print #fileNum, xList Close #fileNum On Error GoTo 0 End Sub TEST2.xlsm

هل يمكن أن ترفق لي الملف ضهرت لدي مشكلة تكرار مراقبة المعلم في نفس اليوم في أكثر من قاعة مثل علي احمد

@محمد هشام. برجاء من كل الاخوة الكرام الي كل من يعرف الاخ محمد هشام او لا يعرفه الي كل من ساعده الاخ محمد هشام او لم يساعده ان يدعو له من كل قلبه و بخالص الدعوات ان يشقي ابنه الغالي واتمنى من الادمن المحترم انه يثبت البوست لفترة وشكرا علي قبول البوست

شكرا جزيلا أخي الفاضل وبارك الله فيك وأكثر الله من أمثالك

وعليكم السلام ورحمة الله تعالى وبركاته جرب الكود التالي اذا ظهر خطا بالكود ربما تحتاج تشغيل تطبيق اكسل كمسؤول Sub DeleteXLSBFromDriveD() Dim folderPath As String folderPath = "D:\" Call DeleteXLSBRecursive(folderPath) MsgBox "تم حذف جميع ملفات .xlsb من الدرايف D (حذف).", vbInformation End Sub Sub DeleteXLSBRecursive(folderPath As String) Dim fs As Object Dim folder As Object Dim subFolder As Object Dim file As Object Set fs = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set folder = fs.GetFolder(folderPath) If folder Is Nothing Then Debug.Print "Cannot access folder: " & folderPath Exit Sub End If On Error GoTo 0 On Error Resume Next Dim fileCount As Long fileCount = folder.Files.Count If Err.Number <> 0 Then Debug.Print "Error accessing files in: " & folderPath & " - " & Err.Description Err.Clear On Error GoTo 0 Exit Sub End If On Error GoTo 0 If fileCount > 0 Then For Each file In folder.Files On Error Resume Next If LCase(fs.GetExtensionName(file.Name)) = "xlsb" Then SetAttr file.Path, vbNormal Kill file.Path If Err.Number <> 0 Then Debug.Print "Failed to delete: " & file.Path & " - Error: " & Err.Description Err.Clear End If End If On Error GoTo 0 Next file End If For Each subFolder In folder.SubFolders DeleteXLSBRecursive subFolder.Path Next subFolder End Sub

السلام عليكم اخى محمد نعم اريد حذف ملفات الاكسيل ذات الامتداد .xlsb من دريف معين حاول كتابة الكود وسنرى مع التجربة كيف نتلافى البطء ان شاء الله

تفضل Data15.rar

أخي أحمد ، جرب هذا التعديل الجديد من حيث الدقة والتوافق بين الشفهي واللياقة ؛ حيث تم اضافة حقلين في جدول اللياقة ( رقم الصف ، وملاحظات ) في المرفق التالي :- فكرة توزيع تلقائي لمستويين (3).mdb

هل يمكن أن ترفق لي الملف