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

للتوضيح : لاسخراج جميع الاوراق في ملف PDF واحد يتضمن جميع الطلاب ربما يتعين عليك مثلا نسخ جميع الاوراق المطبوعة لورقة اخرى اسفل بعضها البعض لتتمكن من حفظها بعد دالك . وهدا يتطلب اظافة ورقة جديدة للمصنف مع انشاء الكود الخاص بدالك . اما في حالة الرغبة في حفظها مستقلة اليك الكود التالي سيقوم بحفظ كل ورقة لوحدها في مجلد باسم شهادات الطلاب بعد تسمية كل ملف باسم الطالب الخاص به Private Sub CommandButton1_Click() Dim i As Integer, fPath As String, F As String Dim WS As Worksheet: Set WS = Sheet31 'Sheets("Sheet3 (2)") ' اسم ورقة العمل Application.ScreenUpdating = False For i = [AA12] To [AC12] If i <= [AA1] Then [AF2] = 2 * (i - 2) + 3 F = [B8] ' اسم الملف On Error Resume Next With ActiveWorkbook ' قم بتعديل اسم المجلد بما يناسبك fPath = .Path & Application.PathSeparator & "شهادات الطلاب" & Application.PathSeparator If Len(Dir(fPath, vbDirectory)) = 0 Then End If MkDir fPath WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & "\" & F & ".pdf", OpenAfterPublish:=False 'طباعة 'WS.PrintOut End With Next i Application.ScreenUpdating = True End Sub 666 PDF.xlsm

اذا كان فورم البحث مبني على استعلام فأن الإستعلام بلا شك قد تم تحديد مربع النص الذي يتم فيه البحث للنموذج الأول . وعند تطبيق الفكرة على النموذج الثاني فإنه سيفتقد الى مربع النص الذي في النموذج الأول . هذا رأيي بالتصور لما شرحت في سؤالك . على العموم ارسل مرفق اذا لم يكون كلامي صحيحاً

راجع المرفق وتأكد فقط الان من الشروط الاربعة هل تحققت .......... Datab (officena).accdb

عجيب !! هذا لا يتصور وغير منطقي !!!! المسألة فيها إنّ المنطق يقول : حذف الصورة من المجلد .. لا علاقة له من قريب او بعيد بالرابط وجلب الصورة منه حاولت ابحث عن موقع يشتمل على صورة ووجدت ... وعملت الحذف ... وحذفت .. ثم جلبت مرة وحذفت .. ومرات وحذفت ... جرب المرفق kan.rar

استاذنا @kkhalifa1960 لسيادتكم جزيل الشكر استاذنا @Foksh لسيادتكم جزيل الشكر

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

وعليكم السلام جرب الكود التالي لعله يفيد حضرتك ولعله المطلوب Sub Export_PDF() Dim SH As Worksheet, R As Range, File_name As String Set SH = ThisWorkbook.Worksheets("Sheet3 (2)") File_name = SH.Range("p8").Value Set R = SH.Range("A1:x35") R.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & File_name End Sub 6666.xlsm 118.pdf

بسم الله الرحمن الرحيم السلام عليكم ورحمه الله وبركاته اساتذتي واخوتى هذا الملف به فهرس لجميع المنتدي ليسهل البحث للاعضاء يوجد فورم يمكنك البحث بها كما يمكنكم استخدام الفلتر العادي وبمجرد الضغط على اي نتيجه من نتائج البحث يتم فتح صفحتها في المنتدي ولا انسي فضل استاذي الكبير ياسر خليل على المساعده في عمل الملف فهرس منتدي الاكسيل.xlsb

السلام عليكم ...بصراحة لم افهم السؤال جيدا انظر للمثال المرفق ...من خلاله حاول ان توصل الفكرة في المثال...تختار من ال list box ...المصروفات التي تريدها EXPENSES VS PROFIT 2-1.rar

لك جزيل الشكر يامدير @kanory

حفظك الله اخي على هذا المجهوووود الراااائع ... في ميزان حسناتك باذن الله

وانا استعجبت تماماً مثلك أستاذي الفاضل . لذا توجهت الى ايجاد طريقة دون الإضطرار الى تحميل الصورة لتلافي مشكلتي التي واجهتني والتي لربما لنسخة الأوفيس أو الإصدار علاقة بالأمر . على العموم تم الحل بما يلي :- في هذا الحدث Form_Current ، يتم تنفيذ الكود عندما يتم تغيير السجل الحالي في النموذج. Private Sub Form_Current() On Error GoTo catch Dim imageURL As String imageURL = Me.texturl.Value If Len(imageURL) > 0 Then Me.Image45.pictureData = GetPictureData(imageURL) Else Me.Image45.pictureData = "" End If catch: Resume Next End Sub يتم استخدام Me.texturl لاسترجاع قيمة الرابط من حقل النص الذي يحتوي على عنوان الصورة . إذا كان الرابط غير فارغ (Len(imageURL) > 0) ، يتم استخدام الرابط لجلب الصورة باستخدام الدالة GetPictureData ، ويتم تعيين البيانات المسترجعة إلى حقل الصورة Me.Image45.PictureData في النموذج . أما إذا كان الرابط فارغًا ، يتم تعيين قيمة فارغة لحقل الصورة . كود الدالة GetPictureData Function GetPictureData(ByVal imageURL As String) As Variant Dim webClient As Object Set webClient = CreateObject("MSXML2.ServerXMLHTTP.6.0") On Error Resume Next webClient.Open "GET", imageURL, False webClient.setRequestHeader "Content-Type", "image/jpeg" webClient.send "" If webClient.Status = 200 Then GetPictureData = webClient.responseBody Else GetPictureData = "" End If On Error GoTo 0 Set webClient = Nothing End Function Pic From URL.accdb

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

ممكن تعمل هكذا .... طبعا مختلف عما تريد ( قوائم تشبه قوائم الاكسس علوية ) .....

أخي @العبيدي رعد ، نود تذكيرك بإغلاق الموضوع ، اذا انتهت مشكلتك في هذا الموضوع ، فقط اختر الإجابة كأفضل إجابة

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

الف شكر وجارى التجربة

اشكرك استاذى بعتذر عن التاخير

مشاركة مع الإخوة لعلها تفيد لحساب مجموع الساعات وتحويلها إلى أيام وساعات، يمكنك استخدام الصيغ التالية في Excel: 1. **جمع الساعات:** - افتح Excel واكتب الساعات في الخلية A1 إلى A4 (على سبيل المثال). - في الخلية الفارغة، اكتب الصيغة التالية: `=SUM(A1:A4)` واضغط Enter. هذه الصيغة ستقوم بجمع جميع الساعات المدخلة. 2. **تحويل الساعات إلى أيام وساعات:** - في الخلية الفارغة، اكتب الصيغة التالية: `=QUOTIENT(B1, 8) & " يوم " & MOD(B1, 8) & " ساعة"` حيث B1 هو الخلية التي تحتوي على مجموع الساعات. ستقوم هذه الصيغة بتحويل الساعات إلى أيام وساعات. على سبيل المثال، إذا كانت الساعات المدخلة هي 45 ساعة، سيكون مجموعها 45 ساعة، وسيتم تحويلها إلى "5 يوم 13 ساعة" باستخدام الصيغ أعلاه. =QUOTIENT(B1, 8) & " يوم " & MOD(B1, 8) & " ساعة"

السلام عليكم عيدكم مبارك بالمرفق كود يقوم نيابة عنك بإكمال البيان الذي تكتبه في عمود معين بورقة عمل استناداً لمجال معين بورقة عمل آخري منفصلة. كيف ؟؟؟؟ الشرح : 1- قم بتدوين البيانات التي تريدها في المجال المسمى AutoCompleteText ضمن العمود A بالورقة المسماة Source data يجب أن تكون البيانات المدخلة غير مكررة . 2- الان انتقل إلى العمود A بالورقة المسماة Test sheet وقم بكتابة الأحرف الأولى المميزة والفريدة لأحد البيانات التي دونتها بالمجال السابق ثم اضغط Enter ،، سيكمل الكود البيان الذي كتبته سلفاً ،،، على سبيل المثال : اكتب حرف Z ثم اضغط Enter ستكون النتيجة في الخلية ZIAD ALI - لأنه النص الوحيد الذي يبدأ بالحرف Z ،،، واذكر بأنه ممكن أن تقوم بزيادة عدد الأعمدة التي ترغب أن يتم فيها عملية استرجاع البيانات بالصفحة المسماة Test sheet عن طريقة التعديل في الكود أرجو أن يكون المرفق مفيد للجميع ،،، ولكم كل الود والتحية. الاكمال التلقائي للبيانات.rar

تفضل استاذ @ابو محمد 4 محاولتي ووافني بالرد . النجارة-1.rar

تفضل اخى الفاضل لعله المطلوب test.xlsx

تفضل استاذ @Abdelaziz Osman المرفق بعد التعديل حسب مافهمت . ووافني بالرد . Datab (officena)-1.rar

وعليكم السلام ورحمة الله تعالى وبركاته Sub SaveFile_Excel() 'في نفس مسار المصنف الرئيسي Excel 'حفظ بصيغة Dim WS As Worksheet, Client As String, path As String, Msg As Variant path = ThisWorkbook.path & "\" Set WS = Worksheet____3: Client = [D3].Value If Len([D3].Value) = 0 Then: MsgBox "المرجوا إظافة إسم العميل", vbExclamation, "Admin": Exit Sub Msg = MsgBox(" تصدير الملف" & " : " & "فاتورة" & " " & Client & "؟", vbYesNo, "Admin") If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False WS.Copy Set rng = [B1:F22] With rng .Value = .Value .Validation.Delete End With For Each shape In ActiveSheet.Shapes shape.Delete Next Application.ActiveWorkbook.SaveAs Filename:=path & Client & ".xlsx", FileFormat:=51 '<-- اظافة التوقيت ' Application.ActiveWorkbook.SaveAs Filename:=Path & Client & "-" & Format(Time, "HH-mm-ss") & ".xlsx", FileFormat:=51 ActiveWorkbook.Close .ScreenUpdating = True .DisplayAlerts = True End With MsgBox "تم نسخ الملف بنجاح" & _ "", vbInformation, Client End Sub حسابات احمد.xlsb

متابعةً مع أستاذنا @Moosak ، تم إضافة بعض التعديلات حسب طلبك . تفضل الكود أولاً . Option Compare Database Option Explicit Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private bMessage20Displayed As Boolean ' متغير لتتبع ما إذا تم عرض الرسالة عند 20% Private bMessage50Displayed As Boolean ' متغير لتتبع ما إذا تم عرض الرسالة عند 50% Private Sub StartBtn_Click() Call ResetProgressPar Call RunProgressPar End Sub Function ResetProgressPar() ' Reset Me.Par2.Left = Me.Par1.Left Me.Par2.Height = Me.Par1.Height Me.Par2.Width = 0 Me.P = "" bMessage20Displayed = False ' إعادة تعيين قيمة المتغير bMessage50Displayed = False ' إعادة تعيين قيمة المتغير End Function Function RunProgressPar() ' Start Dim x As Long Dim percentage As Double For x = 1 To Par1.Width Step 2 Me.Par2.Width = x percentage = CInt((x / Par1.Width) * 100) Me.P = percentage & " %" If percentage = 20 And Not bMessage20Displayed Then MsgBox "20% progress. Press OK to continue.", vbInformation, "Progress Update" bMessage20Displayed = True Sleep 500 End If If percentage = 50 And Not bMessage50Displayed Then MsgBox "50% progress. Press OK to continue.", vbInformation, "Progress Update" bMessage50Displayed = True Sleep 500 End If DoEvents Next End Function تفضل المرفق ، طبعاً قم بتغيير حدث الرسالة بالحدث الذي ترغب به شريط تقدم بدون تايمر.accdb

اخي الكريم @Foksh تسلم ايدك تمام بس فس استفسار بسيط لما بفتح اذن جديد واختار موظف موجود قبل كده هياخد حاجات تانية بيجيب اصناف الاذن القديم اتوماتيك وكمان البيانات مش تنزل في جدول الحركة او الجدول الرئيسي Unif

Sub SaveAsNewWorkbook() Dim wb As Workbook Dim ws As Worksheet Dim newWb As Workbook Dim newWs As Worksheet Dim folderPath As String Dim clientName As String Dim lastRow As Long ' تحديد المجلد المحتوي على الملف الأصلي folderPath = ThisWorkbook.Path ' اسم العميل (يمكنك تغيير هذا إلى الطريقة التي تريد استخدامها لاستخراج اسم العميل) clientName = "اسم العميل" ' تكوين اسم الملف الجديد newFileName = folderPath & "\" & clientName & ".xlsx" ' نسخ ورقة العمل الحالية إلى مصفوفة Set wb = ThisWorkbook Set ws = wb.ActiveSheet ws.Copy ' حفظ المصفوفة كملف إكسل جديد Set newWb = ActiveWorkbook Set newWs = newWb.Sheets(1) Application.DisplayAlerts = False newWb.SaveAs newFileName, FileFormat:=xlOpenXMLWorkbook Application.DisplayAlerts = True ' تحويل المعادلات في النصف العلوي من الفاتورة إلى قيم lastRow = newWs.Cells(Rows.Count, "A").End(xlUp).Row newWs.Rows("1:" & lastRow \ 2).Value = newWs.Rows("1:" & lastRow \ 2).Value ' إظهار رسالة تأكيد الحفظ MsgBox "تم حفظ الملف كـ" & newFileName, vbInformation, "تم الحفظ" End Sub يرجى ملاحظة أنه يجب استبدال "اسم العميل" بالطريقة التي تريد استخدامها لاستخراج اسم العميل

السلام عليكم ورحمة الله وبركاته اخى الفاضل @kkfhvvv تفضل هذا الكود يقوم بتصفية البيانات للثلاث الاعمدة جربه لعله يكون المطلوب Sub RemoveDuplicatesRange() Dim lastRow As Long lastRow = Sheets("البيانات").Cells(Sheets("البيانات").Rows.Count, "O").End(xlUp).Row Sheets("البيانات").Range("O1:Q" & lastRow).Copy Sheets("ارقام").Range("A1").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False lastRow2 = Sheets("ارقام").Cells(Sheets("ارقام").Rows.Count, "A").End(xlUp).Row Sheets("ارقام").Range("$A$2:$C$" & lastRow2).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo End Sub تقبل تحياتى

انا اسف اخى طريقة عرض طلبك يجب ان تبدأ بالسلام عليكم اخوانى وتكتب طلبك ودعم الطلب بملف عموما جرب واخبرنى يمكنك وضع الكود في وحدة VBA في ملف Excel وسيعمل تلقائيًا بمجرد فتح الملف. إليك الخطوات لوضع الكود وجعله يعمل بشكل تلقائي بدون الحاجة لزر: 1. افتح ملف Excel الذي تريد إضافة الكود إليه. 2. اضغط `Alt` + `F11` لفتح محرر VBA. 3. في القائمة، اختر `Insert` > `Module` لإنشاء وحدة VBA جديدة. 4. الصق الكود في وحدة VBA التي تم إنشاؤها. 5. اضغط `Ctrl` + `S` لحفظ الملف. 6. أغلق محرر VBA. 7. أغلق الملف وأعد فتحه. الآن، سيعمل الكود تلقائيًا عند فتح الملف، حيث سيقوم بحفظ وإغلاق الملف تلقائيًا بعد مرور 5 دقائق من الخمول. Dim StartTimer Const IdleTime = 5 ' وقت الخمول بالدقائق Sub ResetTimer() StartTimer = Now End Sub Sub CheckIdleTime() If (Now - StartTimer) * 24 * 60 > IdleTime Then Application.DisplayAlerts = False ' لعدم عرض رسائل التنبيه ThisWorkbook.Save ' حفظ الملف ThisWorkbook.Close ' إغلاق الملف Application.DisplayAlerts = True End If End Sub Private Sub Workbook_Open() StartTimer = Now Application.OnTime Now + TimeValue("00:01:00"), "CheckIdleTime" ' فحص الوقت كل دقيقة End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) ResetTimer End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) ResetTimer End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) ResetTimer End

جرب هدا الحل بعد اظافة اليوزرفورم هل يناسبك باسوورد 0 الاعمال الجنوبية userform.xlsm

الأساسات اولا كما سبق وذكرت .. الجداول وتصميمها بطريقة علمية صحيحة بمايخدم المشروع .. رؤية مسبقة وتصور لما سينتهي عليه المشروع 1- مدخلات 2- مخرجات كل هذا اثناء تصميم الجداول في نهاية هذه المرحلة نكون انجزنا 70% - 80% من المشروع يتبقى 30% هي عملية النماذج والتقارير