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

مشاركة مع الأخي/ @Foksh من يسار الى اليمين =IIf(Month(Date())>=9,Year(Date())+1 & "-" & Year(Date()),Year(Date()) & "-" & Year(Date())-1) من يمين الى اليسار =IIf(Month(Date())>=9,Year(Date()) & "-" & Year(Date())+1,Year(Date())-1 & "-" & Year(Date())) AcademicYear.rar

عذرا اخي الكريم لم أنتبه لأنك تستعمل نسخة أوفيس 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 بالتوفيق

الاخ Foksh والاخ ابو عارف شكرا جزيلا لكما وعاشت الايادي مضبوط 100 بالمئة

وعليكم السلام ورحمة الله تعالى وبركاته استخدم الدالة التالية في مديول :- Function GetAcademicYear() As String Dim currentDate As Date Dim currentYear As Integer Dim nextYear As Integer currentDate = Date currentYear = Year(currentDate) nextYear = currentYear + 1 If currentDate >= DateSerial(currentYear, 9, 1) Then GetAcademicYear = currentYear & " - " & nextYear Else GetAcademicYear = (currentYear - 1) & " - " & currentYear End If End Function في مربع النص اجعل مصدر بياناته = =GetAcademicYear() وتقدر تستخدمه في استعلام على سبيل المثال ، بالشكل التالي :- SELECT IIf(Date() >= DateSerial(Year(Date()), 9, 1), Year(Date()) & " - " & (Year(Date()) + 1), (Year(Date()) - 1) & " - " & Year(Date())) AS AcademicYear; النتيجة :- 1️⃣ إذا كان التاريخ الحالي بعد أو يساوي 1 سبتمبر 2024 ، ستكون النتيجة 2024 - 2025 2️⃣ إذا كان التاريخ الحالي قبل 1 سبتمبر 2024 ، ستكون النتيجة 2023 - 2024 🔚 بهذه الطريقة ، يمكنك الحصول على السنة الدراسية الحالية والسنة اللاحقة بناءً على التاريخ المحدد AcademicYear.accdb

الكود الدي أشرت إليه دوره هو نسخ القيم من عمود B و نسخها الى عمود XFD وازالة التكرارات منه ثم تعيين مصدر بيانات الكومبوبوكس من نفس العمود وهو ما تم استبداله بطريقة متقدمة نوعا ما على الشكل التالي دون الحاجة للنسخ واللصق 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 لست مـتأكدا مما تحاول فعله لاكن إدا كنت تقصد أنك تريد حدف الصفوف الفارغة عند إختيارك فراغ من الكومبوبوكس جرب هدا التعديل 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) 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 CrWS.Range("B1:B" & lastRow).AutoFilter Field:=1, Criteria1:=ky 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 End If Else If Not CrWS Is Nothing Then lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False For i = lastRow To 2 Step -1 If IsEmpty(CrWS.Cells(i, "B").Value) Then CrWS.Rows(i).Delete Next i Application.ScreenUpdating = True UserForm_Initialize End If End If End Sub إما بخصوص تنفيد الكود على نفس المصنف الأخير تعديل صفوف الكلمات المختاره او صفوف الخلايا الفارغة عند اختيارها.xlsm

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

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

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub SaveAsPDF() Dim CrWS As Worksheet: Set CrWS = Sheets("بيانات") Dim lastRow As Long: lastRow = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row Dim xPath As String: xPath = ThisWorkbook.Path & "\كشف_التلاميذ.pdf" CrWS.Range("A2:J" & lastRow).ExportAsFixedFormat Type:=xlTypePDF, Filename:=xPath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub

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

السلام عليكم ورحمة الله تمام أستاذي الكريم .. والله أنا أسف جدا ظهرت مشكلة لم انتبه اليها في القاعدة الاساسية عندي ستظهر لكم في المرفق بعد التعديل وعندما وضعت الكود ظهرت هذه المشكلة وهي ان حقل searinumber غيرت اسمه الى الرقم العام في الخصائص وان محتواه يظهر في الحقل الجديد مربع_تحرير_وسرد156 والله أنا أسف فعلا لم انتبه معذرة لو طلبت من حضرتك تعديل الكود لاني حاولت عدة مرات وفشلت مرفق الالقاعدة مرة ثانية بعد التعديل جزاكم الله خيرا وشكرا لسعة صدرك معي db1.rar

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