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

وعليكم السلام ورحمة الله تعالى وبركاته في Module Option Explicit Sub Filtre() Dim tbl() As Variant, rng As Variant Dim desWS As Worksheet, WS As Worksheet Dim i As Long, j As Long, tmp As Long Set WS = Sheets("ورقة2") Set desWS = Sheets("ورقة1") Application.ScreenUpdating = False desWS.Range("A2:D" & desWS.Rows.Count).ClearContents rng = WS.Range("A2:D" & WS.Cells(Rows.Count, 1).End(xlUp).Row).Value ReDim tbl(1 To UBound(rng), 1 To UBound(rng, 2)) For i = 1 To UBound(rng) If rng(i, 1) <> "" And rng(i, 4) > 0 Then tmp = tmp + 1 For j = 1 To UBound(rng, 2) tbl(tmp, j) = rng(i, j) Next j End If Next i If tmp > 0 Then desWS.Range("A2").Resize(tmp, UBound(tbl, 2)).Value = tbl Application.ScreenUpdating = True End Sub وفي حدث ورقة1 Private Sub Worksheet_Activate() Call Filtre End Sub مثال.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته في الجزء الأخير من الكود قم بإظافة هدا With crWS.PageSetup xlSheet.PageSetup.PaperSize = .PaperSize xlSheet.PageSetup.Orientation = .Orientation xlSheet.PageSetup.LeftMargin = .LeftMargin xlSheet.PageSetup.RightMargin = .RightMargin xlSheet.PageSetup.TopMargin = .TopMargin xlSheet.PageSetup.BottomMargin = .BottomMargin xlSheet.PageSetup.HeaderMargin = .HeaderMargin xlSheet.PageSetup.FooterMargin = .FooterMargin xlSheet.PageSetup.PrintArea = .PrintArea xlSheet.PageSetup.PrintTitleRows = .PrintTitleRows xlSheet.PageSetup.PrintTitleColumns = .PrintTitleColumns xlSheet.PageSetup.Zoom = .Zoom End With ActiveWindow.View = xlPageBreakPreview ActiveWindow.Zoom = 100 حدود طباعة ثابتة v2.xlsm

اشكرك جزيل مهندس هشام ,, جزاك الله كل خير وبارك الله في رزقك

الاستاذ محمد هشام لك من كل التقدير والاحترام دائما لديك المعلومة المفيدة و سرعة الاستجابة ادعو الله بدوام الصحة والعافية والتوفيق والنجاح من اخيك احمد سيد

جرب هذه المعادلة شرح المعادلة ROUND(L4/280*100,1): تقوم هذه الدالة بحساب النسبة المئوية وتقريبها إلى خانة عشرية واحدة. INT(ROUND(L4/280*100,1)): تقوم هذه الدالة بإرجاع الجزء الصحيح من الرقم المقرب. IF(ROUND(L4/280*100,1)=INT(ROUND(L4/280*100,1)),...,...): تقوم هذه الدالة بالتحقق مما إذا كان الرقم المقرب مساويًا للجزء الصحيح منه. إذا كان مساويًا، فهذا يعني أن الرقم صحيح، وإلا فهو عشري. TEXT(ROUND(L4/280*100,1),"0"): إذا كان الرقم صحيحًا، تقوم هذه الدالة بتحويله إلى نص بدون أصفار عشرية. TEXT(ROUND(L4/280*100,1),"0.0"): إذا كان الرقم عشريًا، تقوم هذه الدالة بتحويله إلى نص بخانة عشرية واحدة. مثال إذا كانت L4 تحتوي على 140، فإن الناتج سيكون 50. إذا كانت L4 تحتوي على 141، فإن الناتج سيكون 50.4. آمل أن تكون هذه المعادلة المعدلة تحقق المطلوب. =IF(ROUND(L3/280*100;1)=INT(ROUND(L3/280*100;1));TEXT(ROUND(L3/280*100;1);"0");TEXT(ROUND(L3/280*100;1);"0.0"))

احسنت ا / محمد هشام

السلام عليكم حسب فهمي القاصر كان المروض ان تكتب هكذا ( Me . picpath2) بدل ما في الصورة

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

السلام عليكم ورحمة الله وبركاته أشارك معكم اليوم وحدة نمطية متقدمة باسم basShellExecutor تهدف إلى توفير حلول مرنة وفعالة لتنفيذ الأوامر والملفات في بيئة Windows مع تحكم دقيق بالعمليات تم تصميم هذه الوحدة لتلبية احتياجات المطورين المختلفة والمتنوعة وتعرف او شائعه لدى المطورين باسم : ShellWait ولكن تم اعادة هيكلة وتطوير الوظائف بشكل احترافى لاضفاء أكبر قدر ممكن من الفاعليه والمرونة والكفائه وتعدد الاستخدمات ودعم تنوع الخيارات الممكنه بقدر الإمكان مميزات الكود المرونة: يدعم تنفيذ الأوامر بثلاث طرق (انتظار غير محدود , مهلة زمنية محددة , تنفيذ بسيط) مما يجعله متعدد الاستخدامات الاستجابة: يستخدم " DoEvents " لضمان استجابة واجهة المستخدم أثناء الانتظار مما يمنع تجمد التطبيق التحكم الدقيق: يتيح إنهاء الحلقات يدويا عبر متغير عام (g_TerminateLoops) ويمنع التداخل بين الاستدعاءات باستخدام (m_IsExecuting) التوافق: توافق تعريفات API مع أنظمة 32 بت و64 بت معالجة الأخطاء: يوفر معالجة أخطاء قوية مع رسائل واضحة لتسهيل التصحيح التنظيم: مقسم إلى أقسام واضحة (ثوابت , تعريفات , دوال) مع تعليقات عربية شاملة لتسهيل الصيانة والفهم وظيفة الكود تتيح وحدة basShellExecutor تشغيل الأوامر والملفات بثلاث طرق مختلفة مع القدرة على التحكم في وقت التنفيذ و معالجة الأحداث والتقاط النتائج الدوال الرئيسية هي: ExecuteAndWait: الغرض: تنفيذ أمر أو تشغيل ملف والانتظار حتى اكتماله مع استجابة مستمرة لواجهة المستخدم الاستخدام: مثالي للعمليات التي تحتاج إلى إكمال كامل قبل المتابعة (مثل فتح برنامج وانتظار إغلاقه) ExecuteWithTimeout: الغرض: تنفيذ أمر أو تشغيل ملف مع مهلة زمنية مع إمكانية إنهاء العملية إذا تجاوزت الحد الاستخدام: ممناسب للعمليات ذات الوقت المحدود أو التي قد تتوقف (مثل محاولة استخدام أدوات خارجية) ExecuteWScript: الغرض: تنفيذ أمر بسيط باستخدام " WScript.Shell " مع خيار الانتظار الاستخدام: مفيد للمهام السريعة دون تعقيد على سبيل المثال (مثل تشغيل أوامر CMD) ExecuteWScriptCapture (اختياري): الغرض: تنفيذ أمر والتقاط ناتجه النصي للاستخدام البرمجي الاستخدام: مثالي لتحليل نتائج الأوامر (مثل قوائم الملفات من " dir " ) اسم الوحدة النمطية العامة : basShellExecutor الكود : ' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة) Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit '======================================================================================================================= '------ الثوابت Public Const PROCESS_TIMEOUT_INFINITE As Long = &HFFFFFFFF Public Const PROCESS_STILL_ACTIVE As Long = &H103 Public Const PROCESS_TERMINATED As Long = vbObjectError Or &HDEAD Public Const MAX_PATH_LENGTH As Long = 260 Public Const QS_ALL_INPUT As Long = &H4FF Private Const ERR_NO_COMMAND As Long = vbObjectError Or 1001 Private Const ERR_EXECUTING As Long = vbObjectError Or 1002 Private Const ERR_EXECUTION_FAILED As Long = vbObjectError Or 1003 Private Const ERR_TERMINATION_FAILED As Long = vbObjectError Or 1004 Private Const SHELL_MASK_NOCLOSEPROCESS As Long = &H40 Private Const SHELL_MASK_DOENVSUBST As Long = &H200 Private Const SHELL_MASK_SUPPRESS_ERRORS As Long = &H400 Private Const PROCESS_QUERY_INFO As Long = &H400 Private Const PROCESS_SYNCHRONIZE As Long = &H100000 Private Const PROCESS_TERMINATE As Long = &H1 Private Const ERROR_ACCESS_DENIED As Long = 5 '======================================================================================================================= '------ التعدادات Public Enum ShellWindowStyle WindowHidden = 0 WindowNormal = 1 WindowMinimized = 2 WindowMaximized = 3 WindowNoActivate = 4 End Enum '======================================================================================================================= '------ الأنواع المخصصة #If VBA7 Then Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As LongPtr Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As LongPtr ItemListPointer As LongPtr ClassName As String ClassKeyHandle As LongPtr HotKey As Long IconHandle As LongPtr ProcessHandle As LongPtr End Type #Else Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As Long Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As Long ItemListPointer As Long ClassName As String ClassKeyHandle As Long HotKey As Long IconHandle As Long ProcessHandle As Long End Type #End If '======================================================================================================================= '------ تعريفات API #If VBA7 Then Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr ' فتح مقبض العملية Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long ' إغلاق مقبض العملية Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As LongPtr, Optional ByVal lpDst As LongPtr, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As LongPtr, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As LongPtr) As LongPtr ' إنشاء مؤقت قابل للانتظار Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As LongPtr) As Long ' جلب معرف العملية Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As Long ' تبسيط المسار Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr ' استخراج المعاملات من المسار Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As LongPtr, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As LongPtr, Optional ByVal lpArgToCompletionRoutine As LongPtr, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As Long ' تنفيذ أمر عبر Shell Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long ' إعادة تخصيص السلسلة Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) ' إزالة المعاملات من المسار Private Declare PtrSafe Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #Else Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long ' فتح مقبض العملية Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long ' إغلاق مقبض العملية Private Declare Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long ' إنشاء مؤقت قابل للانتظار Private Declare Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long ' جلب معرف العملية Private Declare Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As Long ' تبسيط المسار Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long ' استخراج المعاملات من المسار Private Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As Long ' تنفيذ أمر عبر Shell Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long ' إعادة تخصيص السلسلة Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) ' إزالة المعاملات من المسار Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #End If '======================================================================================================================= '------ المتغيرات العامة و الخاصة Public g_TerminateLoops As Boolean ' متغير للتحكم في إنهاء الحلقات يدويًا Private m_IsExecuting As Boolean ' علامة لمنع التداخل أثناء التنفيذ '======================================================================================================================= '------------------------------------------- الدوال العامة ' تشغيل أمر والانتظار حتى ينتهي مع استجابة الواجهة Public Function ExecuteAndWait(ByVal CommandLine As String, _ Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, _ Optional ByVal RunAsAdmin As Boolean = False, _ Optional ByVal MaxWaitMs As Long = PROCESS_TIMEOUT_INFINITE) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteAndWait", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ' توسيع متغيرات البيئة ExpandedPath = ExpandEnvVars(CommandLine) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteAndWait", "فشل في تنفيذ الأمر: " & CommandLine End If ProcessHandle = .ProcessHandle End With startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If MaxWaitMs <> PROCESS_TIMEOUT_INFINITE Then If (GetTickCount - startTime) > MaxWaitMs Then Debug.Print "تجاوز الحد الأقصى للانتظار: " & MaxWaitMs & " ميلي ثانية" Exit Do End If End If Loop ExecuteAndWait = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteAndWait", Err.Description End Function ' دالة لتنفيذ أمر مع مهلة زمنية اختيارية وخيار التشغيل كمسؤول Public Function ExecuteWithTimeout(Command As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal TimeoutMs As Long, Optional ByVal RunAsAdmin As Boolean = False, Optional RetryCount As Long = 0) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long Dim RetryIndex As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteWithTimeout", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ExpandedPath = ExpandEnvVars(Command) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If For RetryIndex = 0 To RetryCount With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then If RetryIndex = RetryCount Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteWithTimeout", "فشل في تنفيذ الأمر بعد " & RetryCount + 1 & " محاولات: " & Command End If Else ProcessHandle = .ProcessHandle Exit For End If End With Next RetryIndex startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If TimeoutMs > 0 Then If (GetTickCount - startTime) > TimeoutMs Then If TerminateProcess(ProcessHandle, PROCESS_TERMINATED) = 0 Then Debug.Print "فشل في إنهاء العملية بعد تجاوز المهلة" End If ExitCode = PROCESS_TERMINATED Exit Do End If End If If g_TerminateLoops Then Exit Do Loop ExecuteWithTimeout = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteWithTimeout", Err.Description End Function ' دالة لتشغيل أمر باستخدام WScript.Shell مع خيار الانتظار Public Function ExecuteWScript(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal WaitForCompletion As Boolean = False) As Long Dim WScriptShell As Object On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") ExecuteWScript = WScriptShell.Run(CommandLine, WindowStyle, WaitForCompletion) Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description Err.Raise Err.Number, "ExecuteWScript", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function ' دالة محسنة لتشغيل أمر باستخدام WScript.Shell والتقاط الناتج Public Function ExecuteWScriptCapture(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal) As String Dim WScriptShell As Object Dim ShellExec As Object Dim Output As String On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") Set ShellExec = WScriptShell.Exec(CommandLine) Do While ShellExec.Status = 0 DoEvents Loop Output = ShellExec.StdOut.ReadAll ExecuteWScriptCapture = Output Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description ExecuteWScriptCapture = "" Err.Raise Err.Number, "ExecuteWScriptCapture", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function '======================================================================================================================= '------ الدوال المساعدة ' دالة لتوسيع متغيرات البيئة في سلسلة (مثل %windir%) Private Function ExpandEnvVars(ByVal Path As String) As String Dim Buffer As String Dim Length As Long If InStr(Path, "%") Then Length = ExpandEnvironmentStringsW(StrPtr(Path), 0, 0) If Length > 0 Then Buffer = String$(Length - 1, vbNullChar) If ExpandEnvironmentStringsW(StrPtr(Path), StrPtr(Buffer), Length) Then ExpandEnvVars = Left$(Buffer, Length - 1) Else Debug.Print "فشل توسيع متغيرات البيئة، يتم إرجاع المسار الأصلي: " & Path ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If End Function ' دالة لتبسيط المسار (مثل حل النقاط . و ..) Private Function CanonicalizePath(ByVal Path As String) As String Dim TempPath As String If InStr(Path, "\.") Or InStr(Path, ".\") Then If Len(Path) < MAX_PATH_LENGTH Then TempPath = String$(MAX_PATH_LENGTH - 1, vbNullChar) If PathCanonicalizeW(StrPtr(TempPath), StrPtr(Path)) Then CanonicalizePath = Left$(TempPath, InStr(TempPath, vbNullChar) - 1) Else Debug.Print "فشل تبسيط المسار، يتم إرجاع المسار الأصلي: " & Path CanonicalizePath = Path End If Else CanonicalizePath = Path End If Else CanonicalizePath = Path End If End Function ' دالة لاستخراج المعاملات من المسار Private Function ExtractArguments(ByRef Path As String) As String SysReAllocString VarPtr(ExtractArguments), PathGetArgsW(StrPtr(Path)) If LenB(ExtractArguments) Then PathRemoveArgsW StrPtr(Path) If InStr(ExtractArguments, """") Then ExtractArguments = Replace(ExtractArguments, """", """""") End If End Function ' دالة مساعدة لاستخراج اسم العملية من الأمر Private Function ExtractProcessName(ByVal CommandLine As String) As String Dim Parts() As String Dim FirstPart As String If Left(CommandLine, 1) = """" Then FirstPart = Mid(CommandLine, 2, InStr(2, CommandLine, """") - 2) Else Parts = Split(CommandLine, " ") FirstPart = Parts(0) End If ExtractProcessName = Mid(FirstPart, InStrRev(FirstPart, "\") + 1) End Function ' دالة لإنهاء عملية باستخدام WMI بناءً على اسم العملية Public Function KillProcess(sProcessName As String, Optional sHost As String = ".") As Boolean On Error GoTo Error_Handler Dim oWMI As Object Dim sWMIQuery As String Dim oCols As Object Dim oCol As Object Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2") sWMIQuery = "SELECT Name FROM Win32_Process" Set oCols = oWMI.ExecQuery(sWMIQuery) For Each oCol In oCols If LCase(sProcessName) = LCase(oCol.Name) Then oCol.Terminate End If Next oCol KillProcess = True Error_Handler_Exit: On Error Resume Next Set oCol = Nothing Set oCols = Nothing Set oWMI = Nothing Exit Function Error_Handler: Debug.Print "خطأ في KillProcess: " & Err.Description & " - رقم الخطأ: " & Err.Number KillProcess = False Resume Error_Handler_Exit End Function وأخيــــرا الامثلة : '======================================================================================================================= '------ أمثلة الاستدعاء ' مثال لاستدعاء ExecuteAndWait ' يفتح Notepad وينتظر إغلاقه Sub TestExecuteAndWait() Dim ExitCode As Long On Error Resume Next ExitCode = ExecuteAndWait("notepad.exe C:\test.txt", WindowNormal) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "رمز الخروج: " & ExitCode Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout ' يفتح الحاسبة وينتظر 5 ثوانٍ كحد أقصى Sub TestExecuteWithTimeout() Dim ProcessId As Long On Error Resume Next ProcessId = ExecuteWithTimeout("paint.exe", WindowMaximized, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript ' يشغل أمر dir في CMD وينتظر النتيجة Sub TestExecuteWScript() Dim Result As Long On Error Resume Next Result = ExecuteWScript("cmd.exe /c dir", WindowNormal, True) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript مع إبقاء النافذة مفتوحة Sub TestExecuteWScript_KeepOpen() Dim Result As Long ' استخدام /k بدلاً من /c لإبقاء نافذة CMD مفتوحة بعد تنفيذ الأمر On Error Resume Next Result = ExecuteWScript("cmd.exe /k dir", WindowNormal, False) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout لتشغيل CMD Sub TestExecuteWithTimeoutCMD() Dim ProcessId As Long ' تشغيل CMD مع أمر dir وانتظار 5 ثوانٍ كحد أقصى On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout مع RunAsAdmin وإعادة المحاولة Sub TestExecuteWithTimeoutAdmin() Dim ProcessId As Long ' تشغيل CMD كمسؤول وانتظار 5 ثوانٍ كحد أقصى مع محاولتين On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000, True, 2) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScriptCapture Sub TestExecuteWScriptCapture() Dim CommandOutput As String ' تنفيذ أمر dir والتقاط الناتج On Error Resume Next CommandOutput = ExecuteWScriptCapture("cmd.exe /c dir") Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "ناتج الأمر:" & vbCrLf & CommandOutput Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub تمنياتى القلبيــــه بأكبر قدر ممكن من تحصيل المتعة والاستفاده

جميعا بإذن الله تعالى إذا ركزت قليلا وتوصلت لمعنى المعادلة كنت ستعرف كيف تعدلها لما تريد لأنها فقط تبديل بين قيمة e2 و صفر في شروط IF لاحظ هذا التعديل ربما يفيدك Architect Units.xlsx

تفضل استاذ @فؤاد الدلوي المرفق بعد التعديل بطلبك ... test (555-1).rar

شكرا يا معلم .. أشتغلت بنجاح 😊👌

تفضل أخي Private Const sFolder As String = "الكشوفات PDF" Private Const NamePDF As String = "كشف مناداة" Private Const CrWS As String = "لجان 4" Private Const Logo As String = "IMG" Sub Copy_SavePDFfinal() Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer Dim sPath As String, tempFile As String, img As Shape, r As Shape Dim lastRow As Long, Rng As Range, OnRng As Range Dim f As Worksheet: Set f = Sheets(CrWS) If Not IsNumeric(f.[B1].Value) Or Not IsNumeric(f.[S2].Value) Then Exit Sub début = f.[B1].Value: fin = f.[S2].Value Set OnRng = f.Range("B2:O45") If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & fin & "؟", _ vbYesNo + vbExclamation, "تأكيـــد") = vbNo Then Exit Sub Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Set WS = Sheets("PDF") If WS Is Nothing Then Sheets.Add.Name = "PDF" Set WS = Sheets("PDF") WS.DisplayRightToLeft = True End If On Error GoTo 0 tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile For i = début To fin Step 2 f.[B1].Value = i lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).row If WS.Cells(2, 3).Value = "" Then Set Rng = WS.Range("B" & lastRow + 1) Else lastRow = WS.Range("C:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row Set Rng = WS.Range("B" & lastRow + 5) End If OnRng.Copy Rng.PasteSpecial Paste:=xlPasteValues Rng.PasteSpecial Paste:=xlPasteFormats Rng.PasteSpecial Paste:=xlPasteColumnWidths WS.Cells.NumberFormat = "0;-0;;@" On Error Resume Next Set img = f.Shapes(Logo) If Not img Is Nothing Then img.Copy WS.Paste Destination:=WS.Cells(Rng.row - 1, "F") Set img = WS.Shapes(Logo) img.Top = img.Top If img.Left + img.Width > WS.Range("O1").Left Then img.Left = WS.Range("O1").Left - img.Width End If If img.Top + img.Height > WS.Range("A:O").Rows(WS.Range("A:O").Rows.Count).Top Then img.Top = WS.Range("A:O").Rows(WS.Range("A:O").Rows.Count).Top - img.Height End If End If On Error GoTo 0 For row = 1 To OnRng.Rows.Count WS.Rows(Rng.row + row - 1).RowHeight = OnRng.Rows(row).RowHeight Next row WS.HPageBreaks.Add Before:=WS.Cells(Rng.row + OnRng.Rows.Count, 1) With WS.PageSetup .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5) .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2) .CenterHorizontally = True End With Application.CutCopyMode = False Next i sPath = tempFile & "\" & NamePDF & ".pdf" On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 f.[B1].Value = 1 WS.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح", vbInformation End Sub المصنف v3.xlsb

إدن لنجرب هدا 1) إظهار جميع القيم الموجودة بالعمود سواءا رقمية أو نصية وكدالك الفراغات بعد تمييزها بكلمة فارغة 2) عند اختيار قيمة معينة من عنصر الكومبوبوكس سواءا نصية أو رقمية سيتم حدف الصفوف التي تتضمن القيمة المحددة 3) لجدف الصفوف الفارغة قم بتحديد كلمة فارغة من عنصر كومبوبوكس 1 4) تمت إظافة دالة لترتيب القيم أبجديا على عنصر كومبوبوكس1 لتسهيل العثور على القيمة المطلوبة 5) تم إظافة إعادة ترقيم البيانات على عمود A عند الحدف في حالة كنت بحاجة لدالك Private Sub UserForm_Initialize() Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long Set Tbl = CreateObject("Scripting.Dictionary") If Not CrWS Is Nothing Then lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow > 1 Then For Each c In CrWS.Range("B2:B" & lastRow) If Trim(c.Value) <> "" Then Tbl.Item(c.Value) = c.Value End If Next c End If If Application.WorksheetFunction.CountBlank(CrWS.Range("B2:B" & lastRow)) > 0 Then Tbl.Item("فارغة") = "فارغة" End If If Tbl.Count > 0 Then temp = Tbl.Items Call Tri(temp, LBound(temp), UBound(temp)) Me.ComboBox1.List = temp End If Else MsgBox "المصنف أو الورقة المحددة غير موجودة", vbExclamation End If End Sub Private Sub CommandButton1_Click() Dim lastRow As Long, ky As Variant, c As Range, OnRng As Range If Me.ComboBox1.Value <> "" Then If Not CrWS Is Nothing Then ky = Me.ComboBox1.Value lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False If ky = "فارغة" Then For Each c In CrWS.Range("B2:B" & lastRow) If Trim(c.Value) = "" Then If OnRng Is Nothing Then Set OnRng = c.EntireRow Else Set OnRng = Union(OnRng, c.EntireRow) End If End If Next c Else For Each c In CrWS.Range("B2:B" & lastRow) If IsNumeric(c.Value) And IsNumeric(ky) Then If CDbl(c.Value) = CDbl(ky) Then If OnRng Is Nothing Then Set OnRng = c.EntireRow Else Set OnRng = Union(OnRng, c.EntireRow) End If End If Else If Trim(c.Value) = Trim(ky) Then If OnRng Is Nothing Then Set OnRng = c.EntireRow Else Set OnRng = Union(OnRng, c.EntireRow) End If End If End If Next c End If If Not OnRng Is Nothing Then OnRng.Delete End If With CrWS.Range("A2:A" & CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-1") End With UserForm_Initialize Me.ComboBox1.Value = "" Application.ScreenUpdating = True End If End If End Sub Sub Tri(a, gauc, droi) ref = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call Tri(a, g, droi) If gauc < d Then Call Tri(a, gauc, d) End Sub وأي إستفسار أو تعديل سوف نكون سعداء دائما بحصولك على النتائج المطلوبة بالتوفيق ........ TEST 3.rar

شكر وتقدير واحترام من اخيك

بارك الله فيك وجعله بميزان حسناتك

جزاك الله خير في هذا الشهر الفضيل وبارك الله بجميع اعضاء هذا المنتدى

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

تفضل لعله يكون المطلوب ok ورقة بالفلتر.xlsm

عذرا اخي الكريم لم أنتبه لأنك تستعمل نسخة أوفيس 2007 وبالفعل هذه الميزة غير موجودة فيه يمكنك استعمال كود الطباعة العادي في حالة وجود طابعة pdf في ويندوز يمكنك تجربة هذا الكود Sub ExportWorksheetToPDF_2007() Dim ws As Worksheet Dim pdfFilePath As String Dim wbPath As String Dim objPrinter As Object ' تحديد ورقة العمل الحالية Set ws = ActiveSheet ' الحصول على مسار المصنف الحالي wbPath = ThisWorkbook.Path ' التحقق مما إذا كان المصنف قد تم حفظه If wbPath = "" Then MsgBox "يرجى حفظ المصنف أولاً لتحديد المسار.", vbExclamation Exit Sub End If ' تحديد مسار واسم ملف PDF pdfFilePath = wbPath & "\" & ws.Name & ".pdf" On Error Resume Next ' تحديد طابعة الـ PDF الافتراضية Set objPrinter = CreateObject("Scripting.FileSystemObject") If objPrinter Is Nothing Then MsgBox "لا يمكن تصدير PDF. يرجى التأكد من تثبيت إضافة التصدير.", vbCritical Exit Sub End If ' تصدير الورقة باستخدام طابعة PDF خارجية ws.PrintOut Copies:=1, ActivePrinter:="Microsoft Print to PDF", _ PrintToFile:=True, PrToFileName:=pdfFilePath MsgBox "تم تصدير ورقة العمل إلى ملف PDF بنجاح: " & pdfFilePath, vbInformation End Sub بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته Public Property Get CrWS() As Worksheet Dim wbName As String, wsName As String wbName = "كلية.xlsb" wsName = "قسم" On Error Resume Next Set CrWS = Workbooks(wbName).Sheets(wsName) On Error GoTo 0 End Property Private Sub UserForm_Initialize() Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long Set Tbl = CreateObject("Scripting.Dictionary") If Not CrWS Is Nothing Then lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow > 1 Then For Each c In CrWS.Range("B2:B" & lastRow) If c.Value <> "" Then Tbl.Item(c.Value) = c.Value Next c End If If Tbl.Count > 0 Then temp = Tbl.Items Me.ComboBox1.List = temp End If Else MsgBox "المصنف أو الورقة المحددة غير موجودة", vbExclamation End If End Sub Private Sub CommandButton1_Click() Dim lastRow As Long, ky As String If Me.ComboBox1.Value <> "" Then If Not CrWS Is Nothing Then ky = "=*" & Me.ComboBox1.Value & "*" lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False With CrWS.Range("B1:B" & lastRow) .AutoFilter Field:=1, Criteria1:=ky End With On Error Resume Next CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete On Error GoTo 0 CrWS.AutoFilterMode = False Application.ScreenUpdating = True ' اختار ما يناسبك UserForm_Initialize 'OR ' Unload Me End If End If End Sub TEST.zip

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub test() Dim ws As Worksheet: Set ws = Sheets("توزيع") Dim RowDest As Long: RowDest = 1 Dim Irow As Long, tmp As Long, ky As String Application.ScreenUpdating = False ws.Range("L1:L" & ws.Rows.Count).ClearContents For Irow = 7 To ws.Cells(ws.Rows.Count, "G").End(xlUp).Row ky = ws.Cells(Irow, "G").Value If ky <> "" Then tmp = IIf(ky = "آداب و فلسفة", 7, _ IIf(ky = "لغات أجنبية - إسبانية" Or ky = "لغات أجنبية - ألمانية", 8, 9)) For tmp = 1 To tmp ws.Cells(RowDest, 12).Value = ky & tmp RowDest = RowDest + 1 Next tmp End If Next Irow Application.ScreenUpdating = True End Sub Classeur2 v2.xlsm

جرب هدا =IFERROR(INDEX($G$7:$G$19;MATCH(TRUE;MMULT(--(ROW($G$7:$G$19)>=TRANSPOSE(ROW($G$7:$G$19)));$H$7:$H$19)>=ROWS($6:6);0));"")

بداية استخدم فكرة الأستاذ @أ / محمد صالح لحفظ ورقة العمل بصيغة PDF في هذه المشاركة هنا . أما فيما يتعلق بفكرة الارسال برسالة واتس أب من خلال اكسل فأعتقد الموضوع له تشعبات كثيرة ، ويحتاج للتحديث دائماً ؛ السبب هو تغيير سياسة الارسال في واتس اب ( الموقع او تطبيق ويندوز ) .

للأسف لا يوجد معادلة للقيام بهذا الأمر إلا في الإصدارات الحديثة وربما تكون طويلة ومعقدة ولكن يمكنك استعمال هذا الاجراء Sub RepeatValuesInColumn() Dim ws As Worksheet Dim sourceRow As Long Dim targetRow As Long Dim repeatCount As Long Dim lastRow As Long ' تحديد ورقة العمل Set ws = ActiveSheet ' الحصول على آخر صف يحتوي على بيانات في العمود G lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row ' تحديد صف البدء للعمود J targetRow = 7 ' ابدأ من الصف J7 ' التكرار لكل صف في العمود G وH For sourceRow = 7 To lastRow If ws.Cells(sourceRow, "G").Value <> "" And IsNumeric(ws.Cells(sourceRow, "H").Value) Then repeatCount = ws.Cells(sourceRow, "H").Value If repeatCount > 0 Then Dim i As Long For i = 1 To repeatCount ws.Cells(targetRow, "J").Value = ws.Cells(sourceRow, "G").Value targetRow = targetRow + 1 Next i End If End If Next sourceRow MsgBox "تم التكرار بنجاح!", vbInformation End Sub بالتوفيق

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