بحث مخصص من جوجل فى أوفيسنا
Custom Search
|
نجوم المشاركات
.thumb.gif.27c4a79ce23abc61b721f833e6899131.gif)
Popular Content
Showing content with the highest reputation on 05/30/24 in all areas
-
اخي خلفية اليوزرفوم عبارة عن صورة لا يمكن جلب لونها الا الشريط المتحرك ربمايمكنك تحديد لون يشبه لون الصوة مثلا body BGCOLOR ='&003366' وتعديل حجم الكتابة' بما يناسبك مثلا size='20 Private Sub UserForm_Initialize() Dim LaCouleur As String Dim Te LaCouleur = xlThemeColorLight1 Te = ("برنامج المخازن يرحب بكم . صل على محمد ") Me.WebBrowser1.Navigate _ "about:<html><body BGCOLOR ='&003366' scroll='no'><font color= " & LaCouleur & " size='20' face='NEW'>" & _ "<marquee direction=right>" & Te & "</marquee></font></body></html>" End Sub3 points
-
فعلا مثل هذا المطلوب يحتاج إلى تدخل جراحي (كود vba)2 points
-
لا انا مش عاوز عيونك الحلوين ربنا يحفظهم لك وينور لك بصيرتك انا عاوز مرفق يحقق السيناريو اللى انا عملته بالظبط بدون التعقيدات اللى انت وصفتها دى وانتظر المرفق الجديد لنفس السيناريو فى وحدة نمطية يعمل مع اى نموذج مهما كان لقائمة ازرار راسية وافقيه ولكن لن اضع المرفق الجديد الا بعد ان ارى مرفقكم اولا ولا تزعق لى تانى وتقولى معقد وباكتب اكود معقدة يا اما ترجع لى حاجتى اللى فى مكتبتك العامرة وكل واحد يلعب لحاله2 points
-
Private Sub Report_Open(Cancel As Integer) Dim T, L, B T = Nz(DLookup("top", "settings_Report_tbl"), 1) L = Nz(DLookup("left", "settings_Report_tbl"), 1) B = Nz(DLookup("bottom", "settings_Report_tbl"), 1) Me.Printer.TopMargin = T * 567 Me.Printer.LeftMargin = L * 567 Me.Printer.BottomMargin = B * 567 End Sub هامش تقرير2.rar2 points
-
الحل هنا سيدى بدون تعب فقط افتح القاعدة المرفقة واضغط على زر امر اظهار وتفعيل ورقة الخصائص وادخل الى وضع التصميم property sheet visible or not _ UP V2.mdb1 point
-
راجع هذه المشاركة هنا1 point
-
فكرة الساعات بصراحة هى اللى تعبتنى حبتين ولكن يا استاذى الجليل كنتم السبب فيها بوضعكم لصورة تخيلية عن الموضوع بشكل الساعات وانا تعلمتم على ايديكم ولازلت اتعلم منكم وكل اساتذتى العظماء جزاكم الله عنا كل خير1 point
-
لا شكر على واجب تحت امرك يا دكتور1 point
-
متشكره لحضرتك تعبتك معايا1 point
-
اهلا بيكى يا افندم وفكرة حضرتك حلوة جدا فكرتنى بشئ انتظروا وسوف اوافيكم بأفكار رائعة ان شاء الله1 point
-
اتفضلى يا استاذة @safaa salem5 المرفق هوامش التقارير.accdb1 point
-
انا جديده بالمنتدى وجدة لكي يا صفاء مثال بسيط من احدى المنتديات لتحكم بهوامش الصفحات وعدد طباعة التقرير من غير استخدام دوال اتوقع تشغيل التقارير بحدث التقرير Dim DefaultTop As Long Dim DefaultBottom As Long Dim DefaultLeft As Long Dim DefaultRight As Long ؟! Chack data tablet (1) Function into Report At Top And At Bottom At Mid >> .. How only Building Function Control report ?! sorry for Help U Function Error No Error Now Only Cod On_Click_Button '==================================(OPen_Control Report = ( acHidden)) تحكم بأعدادة طباعة وهوامش التقرير.rar
1 point -
روعه يا بروووف ايه الجمال ده 😛1 point
-
وعليكم السلام ورحمه الله وبركاته لو محتاج كود vba اجهز لك كود1 point
-
الف الف شكر استاذي الفاضل بارك الله فيك هو ده المطلوب بالضبط1 point
-
السلام عليكم اليك الملف بعد التعديل test (2).zip1 point
-
جزاكم الله خيرا وأسف لعدم فهم المقصود وجزى الله الجميع خيرا ونفع بكم1 point
-
تنفيذ ماكرو بناء على قيمة خليه2.xlsb تفضل - الملف الأن يرحل تلقائى بدون الحاجة إلى زر للعمل طوال فترة العمل عليه تنفيذ ماكرو بناء على قيمة خليه2.xlsb1 point
-
كود VBA لترحيل البيانات من شيت Data إلى شيت journal entry ledger Sub TransferData() Dim wsData As Worksheet Dim wsJournalEntryLedger As Worksheet Dim lastRowData As Long Dim lastRowJournalEntryLedger As Long 'حدد ورقة البيانات وورقة دفتر الأستاذ للإدخالات اليومية Set wsData = Worksheets("Data") Set wsJournalEntryLedger = Worksheets("Journal Entry Ledger") 'احصل على آخر صف في ورقة البيانات lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row 'احصل على آخر صف في ورقة دفتر الأستاذ للإدخالات اليومية lastRowJournalEntryLedger = wsJournalEntryLedger.Cells(wsJournalEntryLedger.Rows.Count, "A").End(xlUp).Row 'انقل البيانات من ورقة البيانات إلى ورقة دفتر الأستاذ للإدخالات اليومية For i = 2 To lastRowData wsJournalEntryLedger.Cells(lastRowJournalEntryLedger + 1, "A").Value = wsData.Cells(i, "A").Value wsJournalEntryLedger.Cells(lastRowJournalEntryLedger + 1, "B").Value = wsData.Cells(i, "B").Value wsJournalEntryLedger.Cells(lastRowJournalEntryLedger + 1, "C").Value = wsData.Cells(i, "C").Value wsJournalEntryLedger.Cells(lastRowJournalEntryLedger + 1, "D").Value = wsData.Cells(i, "D").Value wsJournalEntryLedger.Cells(lastRowJournalEntryLedger + 1, "E").Value = wsData.Cells(i, "E").Value wsJournalEntryLedger.Cells(lastRowJournalEntryLedger + 1, "F").Value = wsData.Cells(i, "F").Value lastRowJournalEntryLedger = lastRowJournalEntryLedger + 1 Next i End Sub Bank2 Cr-Dr.xlsb Bank2 Cr-Dr.xlsm Bank2 Cr-Dr.xls1 point
-
اولا اهلا بك بين اخوانك فى المنتدى وبعد اذن اخى الحبيب الاستاذ @عبد الله قدور ليس بالضرورة ان يحتوى مربع السرد على عدة اعمدة هذا اولا ثانيا تعالى نشوف خصائص مربع السرد قبل الاجابة قد يكون عمود واحد قد يكون اكثر من عمور قد يكون قيمته واحدة فقط قد يكون متعدد القيم نستخلص مما سبق ان لكل فرضيه طريقة واسلوب يختلف عن الاخر1 point
-
جزاك الله خير الثواب1 point
-
أحسنت وأكرمك الله وبارك الله فيك وجعل هذا العمل فى ميزان حسناتك ..باطبع عمل ممتاز شكراً جزيلا لجهودكم الكريمة1 point
-
اشكرك اخي الكريم على الرد تم حل المشكلة وكانت متعلقة في نطاق التكرا و تم التعديل1 point
-
عينيه الإتنين .. 😇1 point
-
اولا اعتذر لم انتبه الى رد واجابة والدى الحبيب واستاذى الجليل ومعلمى القدير الاستاذ @ابوخليل يبدو اننى كنت منهمكا فى وضع الاجابة وبعد مشاهدة اجابة والدى الحبيب يبدو انه اعتمد فى الاجابة على تحويل قيم من سنتيمتر إلى twips ولذلك اثراء للموضع الطريقة الثانية اولا ننشئ جدول باسم tblMarginsSettings يحتوى على الجقول الاتية TopMargin (نوع البيانات: Number) BottomMargin (نوع البيانات: Number) LeftMargin (نوع البيانات: Number) RightMargin (نوع البيانات: Number) إنشاء نموذج لإدخال إعدادات الهوامش عناصر التحكم اللازمة لإدخال الهوامش (مربعات نصية) txtTopMargin txtBottomMargin txtLeftMargin txtRightMargin (زر أمر) btnSaveMargins الكود Private Sub btnSaveMargins_Click() ' Ensure only one record in tblMarginsSettings If DCount("*", "tblMarginsSettings") = 0 Then ' If no record, insert a new one DoCmd.RunSQL "INSERT INTO tblMarginsSettings (TopMargin, BottomMargin, LeftMargin, RightMargin) VALUES (" & Me.txtTopMargin & ", " & Me.txtBottomMargin & ", " & Me.txtLeftMargin & ", " & Me.txtRightMargin & ")" Else ' If record exists, update it DoCmd.RunSQL "UPDATE tblMarginsSettings SET TopMargin = " & Me.txtTopMargin & ", BottomMargin = " & Me.txtBottomMargin & ", LeftMargin = " & Me.txtLeftMargin & ", RightMargin = " & Me.txtRightMargin End If MsgBox "Margins settings saved successfully!" End Sub إنشاء الوحدة النمطية لإضافة الدالة العامة الكود Public Function CmToTwips(cm As Double) As Long CmToTwips = cm * 567 End Function وذلك لتحويل القيم من سنتيمتر إلى twips Public Sub SetReportMargins(rpt As Report, _ Optional ByVal DefaultTopCm As Double = 2.54, _ Optional ByVal DefaultBottomCm As Double = 2.54, _ Optional ByVal DefaultLeftCm As Double = 2.54, _ Optional ByVal DefaultRightCm As Double = 2.54) ' Convert default values from cm to twips Dim DefaultTop As Long Dim DefaultBottom As Long Dim DefaultLeft As Long Dim DefaultRight As Long DefaultTop = CmToTwips(DefaultTopCm) DefaultBottom = CmToTwips(DefaultBottomCm) DefaultLeft = CmToTwips(DefaultLeftCm) DefaultRight = CmToTwips(DefaultRightCm) Dim rs As DAO.Recordset On Error GoTo ErrorHandler Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblMarginsSettings") If Not rs.EOF Then rpt.Printer.TopMargin = CmToTwips(Nz(rs!TopMargin, DefaultTopCm)) rpt.Printer.BottomMargin = CmToTwips(Nz(rs!BottomMargin, DefaultBottomCm)) rpt.Printer.LeftMargin = CmToTwips(Nz(rs!LeftMargin, DefaultLeftCm)) rpt.Printer.RightMargin = CmToTwips(Nz(rs!RightMargin, DefaultRightCm)) Else rpt.Printer.TopMargin = DefaultTop rpt.Printer.BottomMargin = DefaultBottom rpt.Printer.LeftMargin = DefaultLeft rpt.Printer.RightMargin = DefaultRight End If rs.Close Set rs = Nothing Exit Sub ErrorHandler: MsgBox "Error setting margins: " & Err.Description If Not rs Is Nothing Then rs.Close Set rs = Nothing End If End Sub على ان يتم الاستدعاء فى التقرير عند فتح التقرير بالشكل التالى Private Sub Report_Open(Cancel As Integer) SetReportMargins Me End Sub1 point
-
اولا ننشئ جدول باسم tblMarginsSettings يحتوى على الجقول الاتية TopMargin (نوع البيانات: Number) BottomMargin (نوع البيانات: Number) LeftMargin (نوع البيانات: Number) RightMargin (نوع البيانات: Number) إنشاء نموذج لإدخال إعدادات الهوامش عناصر التحكم اللازمة لإدخال الهوامش (مربعات نصية) txtTopMargin txtBottomMargin txtLeftMargin txtRightMargin (زر أمر) btnSaveMargins الكود Private Sub btnSaveMargins_Click() ' Ensure only one record in tblMarginsSettings If DCount("*", "tblMarginsSettings") = 0 Then ' If no record, insert a new one DoCmd.RunSQL "INSERT INTO tblMarginsSettings (TopMargin, BottomMargin, LeftMargin, RightMargin) VALUES (" & Me.txtTopMargin & ", " & Me.txtBottomMargin & ", " & Me.txtLeftMargin & ", " & Me.txtRightMargin & ")" Else ' If record exists, update it DoCmd.RunSQL "UPDATE tblMarginsSettings SET TopMargin = " & Me.txtTopMargin & ", BottomMargin = " & Me.txtBottomMargin & ", LeftMargin = " & Me.txtLeftMargin & ", RightMargin = " & Me.txtRightMargin End If MsgBox "Margins settings saved successfully!" End Sub إنشاء الوحدة النمطية لإضافة الدالة العامة الكود Public Sub SetReportMargins(rpt As Report, _ Optional ByVal DefaultTop As Long = 1440, _ Optional ByVal DefaultBottom As Long = 1440, _ Optional ByVal DefaultLeft As Long = 1440, _ Optional ByVal DefaultRight As Long = 1440) ' Default values are set to 1 inch (1440 twips) which is standard for A4 paper Dim rs As DAO.Recordset On Error GoTo ErrorHandler Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblMarginsSettings") If Not rs.EOF Then rpt.Printer.TopMargin = Nz(rs!TopMargin, DefaultTop) rpt.Printer.BottomMargin = Nz(rs!BottomMargin, DefaultBottom) rpt.Printer.LeftMargin = Nz(rs!LeftMargin, DefaultLeft) rpt.Printer.RightMargin = Nz(rs!RightMargin, DefaultRight) Else rpt.Printer.TopMargin = DefaultTop rpt.Printer.BottomMargin = DefaultBottom rpt.Printer.LeftMargin = DefaultLeft rpt.Printer.RightMargin = DefaultRight End If rs.Close Set rs = Nothing Exit Sub ErrorHandler: MsgBox "Error setting margins: " & Err.Description If Not rs Is Nothing Then rs.Close Set rs = Nothing End If End Sub على ان يتم استدعاءه فى التقرير عندف تح التقرير بالشكل التالى Private Sub Report_Open(Cancel As Integer) SetReportMargins Me End Sub وبذلك يكون هناك مرونة مع المعلمات الافتراضية للدالة SetReportMargins تتيح تحديد هوامش افتراضية في حال عدم وجود قيم في الجدول تم استخدام معايير A4 حيث ان القيم الافتراضية للهوامش تعادل 1 بوصة (1440 twips) لكل جانب وهي مناسبة لمقاسات ورق A4 يمكن استدعاء الدالة من أي تقرير بسهولة باستخدام هذا الكود، ستكون إعدادات الهوامش مرنة وقابلة للتعديل بسهولة، مع التأكد من وجود قيم افتراضية مناسبة عند الحاجة.1 point
-
استاذ @أبو أحمد لأن هذه تكررت منك أذهب هنـــــــا وعدل أفضل اجابة لصاحب الحل وليس انت كما فعلت . حتى نتفاعل مع متطلبات الأن ومستقبلاً .1 point
-
مشاء الله تبارك الله معلم مبدع .................... زادك الله علما وابداعا1 point
-
شكر وتقدير واحترام من اخيك1 point
-
عظمة على عظمة يا سيد المعلمين لله درك .. دايما تجيب الديب من ديله .. بسم الله ما شاء الله تبارك الله 😂 روووح ربنا يوفقك يا عم 😊🌼🌹1 point
-
ماشاء الله مبدع دائما استاذنا الجميل @ابو جودي زادك الله من علمه وفضله 🌹🌹1 point
-
استاذنا @ابو جودي من أول مرة ساعدتني وأنت مبدع . جزاك الله كل خير .1 point
-
تم إضافة التأثيرات الصوتية الى التحديث الجديد . تم إضافة اسماء اللاعبين في مربعات نص . تم تعديل التعليقات من اللغة الإنجليزية الى اللغة العربية . تم إضافة تاثير الحركة الإنتقالية المرئية . تم إضافة زر لإيقاف الأصوات أو تشغيلها أثناء اللعب . Snake.zip1 point
-
ممكن تجرب الكود Sub CreateFolder() Dim ws As Worksheet Dim lastRow As Long Dim folderPath As String Dim folderName As String Dim fullPath As String Dim i As Long Set ws = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير "Sheet1" إلى اسم ورقة العمل الخاصة بك lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' تحديد آخر صف في العمود A (يمكن تغيير العمود إذا لزم الأمر) For i = 2 To lastRow ' يبدأ من الصف 2 ليتخطى العناوين folderPath = ws.Cells(i, 3).Value ' عمود C folderName = ws.Cells(i, 4).Value ' عمود D If folderPath <> "" And folderName <> "" Then fullPath = folderPath & "\" & folderName If Dir(fullPath, vbDirectory) = "" Then MkDir fullPath MsgBox "Folder created: " & fullPath, vbInformation Else MsgBox "Folder already exists: " & fullPath, vbExclamation End If End If Next i End Sub1 point
-
نعم اقصد ذلك ياريت يااستاذ تعمل لى الوحدة النمطية هذا اكون شاكرا لحضرتك1 point
-
استكمالاً لما سبق في المشروع والإنتهاء منه 👆 :- وقد انتهيت ولله الحمد من برنامج صلوات 2024 Salawat ، مع آخر إضافة وهي إتجاه القبلة . في المرفق تم إضافة ملفي صوت أذان بإمتداد Mp3 ، بصوت الشيخ منصور الزهراني و الشيخ ماجد الهمذاني ؛ وتستطيع التغيير حسب الرغبة .
1 point -
جرب هذا التعديل على حسب فهمي Sub Test() Dim Sh As Worksheet, Ws As Worksheet, i As Long, lr As Long, DestPath Set Sh = ThisWorkbook.Worksheets("School Fee Receipt") Set Ws = ThisWorkbook.Worksheets("Daily Report") lr = Application.Max(5, Ws.Cells(Rows.Count, "b").End(xlUp).Row) + 1 For i = 22 To 15 Step -1 If Sh.Cells(i, "H") <> 0 Then Ws.Range("B" & lr) = Sh.Range("E10") Ws.Range("C" & lr) = Sh.Range("E12") Ws.Range("D" & lr) = Sh.Range("e11") Ws.Range("E" & lr) = Format(Sh.Range("H9"), "[$-1010000]yyyy/mm/dd;@") Ws.Range("F" & lr) = Sh.Range("H10") Ws.Range("G" & lr) = Sh.Cells(i, "G") Ws.Range("H" & lr) = Sh.Cells(i, "H") Exit For End If Next i DestPath = ThisWorkbook.Path & "\" & Sh.Range("e11") & ".pdf" SH.ExportAsFixedFormat Type:=xlTypePDF, Filename:=DestPath End Sub1 point
-
ا ممكن مرفق ان امكن بعد سحب الاوراق من الماسح الضوئي صور فيدر جعل الصور مقصوصة بحجم الصفحة المطلوبة بطول والعرض يكون السحب بحجم الورق A4 او اي حجم احدد الطولة والعرض وشكرا0 points
-
عملت نفس الطريقه دى بس مش شغال معايا عند فتح التقرير بيطلب من ادخل الهوامش هامش التقرير.accdb0 points
-
وعليكم السلام ورحمة الله وبركاته باش مهندسنا الحاضر الغائب @ابو جودي 🙂 دا شكلي وأنا ببص على الأكواد 😂😂😂 وأنا بقول دام الموضوع تحدي بينك وبين نفسك .. مش عايز أخش بينكم أخاف يكبر الموضوع بينكم ويجيني بوكس من هنا ولا هناك 😅👊🏻 لكن أنا شايف أنك طولتها وهي قصيرة يابوحميد .. 😁🖐 دامك رجعت تعتمد على التاج Tag والـ TabIndex للأزرار فأعتقد أنك في غنى عن هذي السلسلة الطويلة من الأوامر .. فممكن بكود قصير يتعرف على التاج وأيضا تعيد ترتيب مسميات الأزرار بشكل متسلسل ممكن تحقق النتيجة اللي أنت عاوزها0 points
.thumb.jpg.cf3a614b0faa58c448218f6688c0e822.jpg)
.thumb.jpg.b124d26c2863db72dbed5b90b81fdfb8.jpg)
(1).thumb.gif.3369bc21e7688379f05218e4ca64e807.gif)
