نجوم المشاركات

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

جرب تبحث هنا 🙂 : https://arbfonts.com/naskh-arabic-fonts/page/15?preview=الجمهورية+الجزائرية

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

برنامج أرشفة 1- الملفات والمرفقات والمجلدات 2- البرامج المساعدة ومرفقاتها أرجو ابداء رأيكم به ArchiveMyFiles-Folders.rar

على افترض أن لدينا 100 معلم منهم 8 بلجنة التصحيح ولدينا 12 لجنة امتحان ولدينا 8 مواد بــ 8 ايام امتحانات اليكم التوزيع مع مراعاة العدالة في كل شئ ... واصدار تقريران الاول التوزيع حسب كل مادة امتحان كل مادة بصفحة .... والثاني للاحصائيات فقط اذهب لنهايته ستحصل على جدول بالاحصائيات .. ولكم مني كل الاحترام والتقدير . توزيع المراقبين على اللجان.rar

تم تعديل الكود ............................ Dim db As DAO.Database Dim rsA As DAO.Recordset, rsB As DAO.Recordset Dim rsRooms As DAO.Recordset, rsDays As DAO.Recordset, rsTarget As DAO.Recordset Dim supervisionDate As Date, roomName As String Dim teacherAssignedA As Boolean, teacherAssignedB As Boolean Dim dayKey As String Dim safeName As String Dim teacherName As String On Error GoTo ErrorHandler Set db = CurrentDb() ' 1. التهيئة: مسح الجدول وتصفير العدادات db.Execute "UPDATE Teachers SET SupervisionCount = 0" db.Execute "DELETE FROM TeacherAssignment" ' 2. التحقق من توفر عدد كافٍ من المعلمين Dim totalSupervisionsNeeded As Long Dim availableA As Long, availableB As Long Dim daysCount As Long, roomsCount As Long daysCount = DCount("*", "SupervisionDays") roomsCount = DCount("*", "ExamRooms") totalSupervisionsNeeded = daysCount * roomsCount ' معلم A ومعلم B لكل قاعة ' حساب المعلمين المتاحين مع مراعاة جميع شروط الاستثناء availableA = DCount("*", "Teachers", "TeacherCategory = 'A' " & _ "AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays)) " & _ "AND (CorrectionCommittee Is Null OR CorrectionCommittee = '')") availableB = DCount("*", "Teachers", "TeacherCategory = 'B' " & _ "AND (ExamDate Is Null OR ExamDate Not In (SELECT SupervisionDate FROM SupervisionDays)) " & _ "AND (CorrectionCommittee Is Null OR CorrectionCommittee = '')") If availableA < totalSupervisionsNeeded Or availableB < totalSupervisionsNeeded Then Dim response As VbMsgBoxResult response = MsgBox("تحذير: عدد المعلمين غير كافي!" & vbCrLf & _ "المطلوب: " & totalSupervisionsNeeded & " معلم A و " & totalSupervisionsNeeded & " معلم B" & vbCrLf & _ "المتاح: " & availableA & " معلم A و " & availableB & " معلم B" & vbCrLf & _ "هل تريد المتابعة مع وضع 'غير مغطاة' للقاعات غير المكتملة؟", _ vbYesNo + vbExclamation, "تنبيه") If response = vbNo Then MsgBox "تم إلغاء التوزيع بناءً على طلبك.", vbInformation Exit Sub End If End If ' 3. بدء عملية التوزيع Set rsDays = db.OpenRecordset("SELECT * FROM SupervisionDays ORDER BY SupervisionDate", dbOpenDynaset) Set rsRooms = db.OpenRecordset("SELECT * FROM ExamRooms ORDER BY RoomName", dbOpenDynaset) Set rsTarget = db.OpenRecordset("TeacherAssignment") ' إنشاء قاموس لتتبع المعلمين في كل يوم على حدة Dim dailyTeachers As Object Set dailyTeachers = CreateObject("Scripting.Dictionary") ' حلقة على كل الأيام Do While Not rsDays.EOF supervisionDate = rsDays!supervisionDate ' تهيئة القاموس لهذا اليوم فقط (ليسمح بالتكرار في الأيام الأخرى) dailyTeachers.RemoveAll ' حلقة على كل القاعات rsRooms.MoveFirst Do While Not rsRooms.EOF roomName = rsRooms!roomName teacherAssignedA = False teacherAssignedB = False ' تعيين معلم فئة A Set rsA = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='A' " & _ "AND (ExamDate Is Null OR ExamDate <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "AND (CorrectionCommittee Is Null OR CorrectionCommittee = '') " & _ "ORDER BY SupervisionCount ASC", dbOpenDynaset) If Not rsA.EOF Then rsA.MoveFirst Do Until rsA.EOF Or teacherAssignedA teacherName = rsA![teacherName] If Not dailyTeachers.Exists(teacherName) Then ' تعيين المعلم A rsTarget.AddNew rsTarget!teacherName = teacherName rsTarget!TeacherCategory = "A" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update ' تحديث العداد safeName = Replace(teacherName, "'", "''") db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE [TeacherName] = '" & safeName & "'" ' إضافة المعلم للقاموس اليومي فقط dailyTeachers.Add teacherName, 1 teacherAssignedA = True End If rsA.MoveNext Loop End If rsA.Close ' إذا لم يتم تعيين معلم A، تسجيل "غير مغطاة" If Not teacherAssignedA Then rsTarget.AddNew rsTarget!teacherName = "غير مغطاة" rsTarget!TeacherCategory = "A" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update End If ' تعيين معلم فئة B Set rsB = db.OpenRecordset("SELECT * FROM Teachers WHERE TeacherCategory='B' " & _ "AND (ExamDate Is Null OR ExamDate <> #" & Format(supervisionDate, "mm/dd/yyyy") & "#) " & _ "AND (CorrectionCommittee Is Null OR CorrectionCommittee = '') " & _ "ORDER BY SupervisionCount ASC", dbOpenDynaset) If Not rsB.EOF Then rsB.MoveFirst Do Until rsB.EOF Or teacherAssignedB teacherName = rsB![teacherName] If Not dailyTeachers.Exists(teacherName) Then ' تعيين المعلم B rsTarget.AddNew rsTarget!teacherName = teacherName rsTarget!TeacherCategory = "B" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update ' تحديث العداد safeName = Replace(teacherName, "'", "''") db.Execute "UPDATE Teachers SET SupervisionCount = SupervisionCount + 1 WHERE [TeacherName] = '" & safeName & "'" ' إضافة المعلم للقاموس اليومي فقط dailyTeachers.Add teacherName, 1 teacherAssignedB = True End If rsB.MoveNext Loop End If rsB.Close ' إذا لم يتم تعيين معلم B، تسجيل "غير مغطاة" If Not teacherAssignedB Then rsTarget.AddNew rsTarget!teacherName = "غير مغطاة" rsTarget!TeacherCategory = "B" rsTarget!ExamRoom = roomName rsTarget!supervisionDate = supervisionDate rsTarget.Update End If rsRooms.MoveNext Loop rsDays.MoveNext Loop ' 4. التنظيف وإغلاق الموارد rsTarget.Close rsRooms.Close rsDays.Close Set rsTarget = Nothing Set rsRooms = Nothing Set rsDays = Nothing Set rsA = Nothing Set rsB = Nothing Set db = Nothing Set dailyTeachers = Nothing MsgBox "تم الانتهاء من التوزيع بنجاح!" & vbCrLf & _ "تم تعيين معلم A ومعلم B لكل قاعة" & vbCrLf & _ "مع مراعاة الشروط التالية:" & vbCrLf & _ "- عدم تكرار المعلم في نفس اليوم" & vbCrLf & _ "- السماح بتكرار المعلم في أيام مختلفة" & vbCrLf & _ "- استثناء المعلمين الذين لديهم اختبار في نفس اليوم" & vbCrLf & _ "- استثناء المعلمين في لجان التصحيح" & vbCrLf & _ "- العدالة في التوزيع حسب عدد المراقبات السابقة", _ vbInformation, "إنجاز" Exit Sub ErrorHandler: MsgBox "حدث خطأ أثناء التنفيذ: " & vbCrLf & _ "رقم الخطأ: " & Err.Number & vbCrLf & _ "الوصف: " & Err.Description & vbCrLf & _ "في الإجراء: " & Erl, vbCritical, "خطأ" Resume Next اكتب اي عبارة حتى لو رقم المهم الا يكون الحقل فارغ ......

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

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

اخي الكريم الكود شغال تمام و أيضا سريع لم يستغرق عندي 5 ثواني لتصدير الملفات جرب تشغلية على كمبيوتر آخر

وعليكم السلام ورحمة الله وبركاته .. حيا الله بمهندسنا العود @jjafferr 😃🖐 هذي اللخبطة تحصل لما يكون الكود فيه نص عربي وتجى تنسخه لما يكون مؤشر اللغة على الإنجليزي >>> وهذا عندك مثال للتجربة 🙂 : Function GetFileExt(strPath As String) As String ' ÏÇáÉ ááÍÕæá Úáì ÅãÊÏÇÏ ÇáãáÝÇÊ ãÚ ÇáäÞØÉ Dim strFile As String strFile = Right(strPath, Len(strPath) - InStrRev(strPath, "\")) GetFileExt = Right(strFile, Len(strFile) - InStrRev(strFile, ".") + 1) End Function

أظن أن الأمر ليس بالصعب يمكننا تعديل الكود ليتناسب مع طلبك بحيث يقوم بحدف الملفات سواءا بداخل البارتيشن المحدد مباشرة أو بداخل الملفات الفرعية بما أنه من الصعب تجربة الكود على الملفات الخاصة بي قمت بإنشاء بارتيشن إظافي بإسم F فقط للتجربة يمكنك تغييره بداخل الكود على حسب احتياجاتك مع إظافة كود لإنشاء ملفات بصيغة XLSB للتجربة عليها كما في المثال التالي TEST3.xlsm

السلام عليكم اخوي موسى بالفعل ، عمل لا يخطر على البال ، شكرا لك ولأخوي ابو جودي عندي فكرة في بالي لتطوير العمل ، ولأنك لم ترفق اصل النص المتخربط وانما ارفقت صورة ، فمحتاج منك النص لوسمحت (وخليه في الكود في مرفق) صدقني حاولت انسخه ، ولكن لما الصقه في كود الاكسس يتحول الى نص طبيعي انا مربوش شوي في شغل ، فما عندي بارض احاول اكثر

ما ادري !! عملت مقارنة بخطوط الوندوز اللي عندي (وما عندي خطوط اضافية) ، فالاقرب كان Times New Roman وطلبت من claude.ai يعمل المقارنة :

السلام عليكم ورحمة الله وبركاته اليك ما طلبت 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

ادن لنجرب طريقة أخرى 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

بسم الله الرحمان الرحيم السلام عليكم اصدقائي اعضاء منتدى اوفيسنا تم الانتهاء بحمد لله من قاعدة البيانات تم الاعتماد على الاكسيس كقاعدة البيانات لذى لن يكون هناك اي ثقل او ضغط على الاكسيل فواتير الشراء و فواتير البيع اضافة فاتورة بحث وتعديل او طباعة البحث عن الاصناف باستعمال خاصية النص التنبئي اتبعنا السعر الوسط للاصناف في حال توفر كميات مختلفة باسعار مختلفة في المخزون الاصناف الجديدة تدخل اوتوماتيكيا الى المخزن مباشرة من فاتورة الشراء و كذالك يتم تكويدها اوتوماتيكيا امكانية اضافة القيمة المضافة للفواتير حسب ارادة المستخدم اضهار ان كانت الفاتورة مسددة ام لا و ايضا اضهار ان كان مسدد جزء من الفاتورة و المبلغ المتبقي الموردين و العملاء اضافة بحث وتعديل او حذف اضهار كل الفواتير المتعلقة بالعميل او المود اضهار الفواتير الغير مسددة او الغير مدفوعة للعميل او المورد كشف حساب تفصيلي لكل عميل او مورد طباعة كشف الحساب اضهار عدد الفواتير المتعلقة بكل عميل او مورد و اضهار مجموع المبالغ المدفوعة او المسددة و مجموع المبالغ المستحقة المخزون قائمة كل الاصناف مع امكانية التعديل على اسم الصنف اضهار قائمة بالاصناف القريبة النفاذ وذلك على حسب كمية يحددها المستخدم اضهار قائمة الاصناف التي نفذت من المخزون قائمة بكل عمليات الشراء الخاصة بكل صنف قائمة بكل عمليات البيع الخاصة بكل صنف صافي ربح الصنف امكانية استراد قائمة اصناف من ملف اكسل خارجي جاري العمل عللى مكانية استراد الاصناف من صيغ اخرى كالاكسيس او الملفات النصية سندات الصرف و سندات القبض اضافة بحث وتعديل او حذف + طباعة السندات بحث بواسطة رقم السند او رقم الفاتورة او اسم العميل او المورد او بين فترة زمنية معينة اثناء اضافو السندات سواء قبض او صرف لا تضهر الى الفواتير الغير مسددة عند اختيار الفاتورة يضهر مبلغها اوتوماتيكيا امكانية اختيار طريقة الدفع نقدا او شيك مضهر البرنامج امكانية تغير ثيم البرنامج امكانية تغير لغة البرنامج (عربية انجليزة و فرنسية) يعتمد البرنامج على واجهة الاكسل الرئيسة و اليوزرفورم معا معلومات اخرى امكانية رفع قاعدة بيانات البرنامج على سيرفر محلي او عام (لاخوف على قاعدة البيانات في حال سقوط الونداوز) امكانية العمل على البرنامج من طرف اكثر من مستخدم في وقت واحد هذه بعض الصور المسربة للبرنامج هذا ماتم انجازه بفضل الله الى حد الساعة لذى احتاج من كل الاعضاء ابداء اقتراحاتهم حول الامور المنجزة و ايضا اعطائنا اي اضافات تودون ان اضيفها للبرنامج لانه لم يعد يتوفر في جعبتي اي افكار لذي ارجو من لهم خبرة في التعامل مع هذا النوع من البرامج ان يبدو اقتراحاتهم او يرةني بعض البرامج التي يمكن ان استمد منها افكار اخرى تحياتي للجميع اخوكم في الله شوقي ربيع

Dim Sh As Boolean Public Property Get f() As Worksheet Set f = Sheets("Sheet1") <========= إسم ورقة العمل المرغوب جلب إسم المصنف الجديد منها End Property Private Sub UserForm_Initialize() Dim WS As Worksheet, CrWS As Variant, i As Integer ' قم بتعديل أسماء أوراق العمل المرغوب إظهارها CrWS = Array("Sheet1", "Sheet2", "Sheet3") For Each WS In ThisWorkbook.Worksheets For i = LBound(CrWS) To UBound(CrWS) If WS.name = CrWS(i) Then ListBox1.AddItem WS.name Exit For End If Next i Next WS HideBar Me End Sub Private Sub CommandButton1_Click() Dim i As Integer, ShName As String, newWb As Workbook, sPath As String Dim tmps As Integer, shArr As String, sCount As Integer, WBname As String WBname = f.[R2].Value <======= قم بتعديل عنوان خلية الإسم بما يناسبك If WBname = "" Then: MsgBox "الرجاء إدخال إسم المصنف ", vbExclamation, "إنتباه": Exit Sub 'Code........ .............. End Sub Private Sub CommandButton2_Click() On Error GoTo SupApp Dim arr As New Collection, TempWb As Workbook, WS As Worksheet Dim i As Integer, sMsg As Integer, tbl As Boolean Dim WBname As String, sPath As String, shArr As String WBname = Trim(f.Range("R2").Value) If WBname = "" Then MsgBox "الرجاء إدخال اسم المصنف", vbExclamation, "تنبيه": Exit Sub tbl = Me.CheckBox1.Value For i = 0 To Me.ListBox1.ListCount - 1 If tbl Or Me.ListBox1.Selected(i) Then arr.Add Me.ListBox1.List(i) shArr = shArr & Me.ListBox1.List(i) & "- " sMsg = sMsg + 1 End If Next If sMsg = 0 Then MsgBox "الرجاء تحديد ورقة عمل واحدة على الأقل", vbExclamation, "تنبيه": Exit Sub If Len(shArr) > 0 Then shArr = Left(shArr, Len(shArr) - 2) End If If MsgBox("هل أنت متأكد أنك تريد حفظ الأوراق التالية؟" & _ vbNewLine & vbNewLine & shArr, vbYesNo + vbQuestion, "PDF" & " تأكيد الحفظ") = vbNo Then Exit Sub With Application .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False: .Calculation = xlCalculationManual End With Set TempWb = Workbooks.Add(xlWBATWorksheet) For i = 1 To arr.Count ThisWorkbook.Sheets(arr(i)).Copy After:=TempWb.Sheets(TempWb.Sheets.Count) Next sPath = ThisWorkbook.path & "\" & WBname & ".pdf" If Dir(sPath) <> "" Then Kill sPath TempWb.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False TempWb.Close False MsgBox "تم حفظ الملفات بنجاح", vbInformation, "PDF حفظ" Unload Me CleanUp: With Application .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic End With Exit Sub SupApp: On Error Resume Next: If Not TempWb Is Nothing Then TempWb.Close False Resume CleanUp End Sub تصدير صفحات v3.xlsm

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

جرب التالي .. لاحظ أن الموضوع الذي اقتبست منه الكود فيه رابط لحلقات افتح الباب وفيه تفصيل أكثر لو احببت الإطلاع عليه Sub Sort_Female() Dim LR As Long LR = Range("M" & Rows.Count).End(xlUp).Row Range("K7:R" & LR).Sort Key1:=Range("R7:R" & LR), Order1:=xlAscending, Key2:=Range("M7:M" & LR), Order2:=xlAscending, Header:=xlNo End Sub Sub Sort_Male() Dim LR As Long LR = Range("M" & Rows.Count).End(xlUp).Row Range("K7:R" & LR).Sort Key1:=Range("R7:R" & LR), Order1:=xlDescending, Key2:=Range("M7:M" & LR), Order2:=xlAscending, Header:=xlNo End Sub يوجد معادلات في النطاق وبعد تنفيذ الأكواد تعطي خطأ VALUE لا أعلم السبب في ذلك ..يرجى مراجعة الملف بشكل جيد والوقت لا يسعني الآن للإطلاع على الملف عموماً أترك الأمر لإخواني بالمنتدى ليدرسوا المشكلة بشكل أعمق تقبل تحياتي

هههههههههههههههه يعنى هو خلاص على راسى ريشه المقصود بالانتظار انك لاتستعجل فى تنفيذ اقتراحك نحو تبديل الملف حيث يمكنك تبديله وقتما يسمح وقتك بذلك هذا هو المقصود ما إنت عارف كل واحد وثقافته ماهى ألمانى ههههههههههههههه اليك أخى الحبيب المرفق الجديد والجديد به تطبيق لمثال عملى بالمعادلات واى إستفسار فأخيكم دائما فى خدمتكم برجاء تعديل كلمة " لخليتين " بالصف السابع من المشاركة الاولى مع تفضلت به من إقتراح جزاكم الله خيرا ***** تقبل وافر تقديرى واحترامى حساب الدمغه العادية ق 111 لسنة 1981 بالمعادلات والدلات المعرفة + التطبيق - سعيد بيرم.rar