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

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

وعليكم السلام ورحمة الله وبركاته فكرة pdf انه يقوم بانشاء صفحة مؤقتة بها اسماء الموظفين وكل موظف قي ورقة ثم يصدرها الى pdf قم يحذف الورقة عدد الموظفين لديك حوالى 350 موظف بمعنى يتم انشاء حوالى 350 ورقة المقصود مما سبق دكره ان الكود سيأحد بعض الوقت لتنفيذ الامر ويعتمد الامر على مواصفات الجهاز بالنسبة لجهازي تطلب الامر دقيقة ونصف بمواصفات في حدود الجيدة اليك الملف مرتب الفنيين عن شهر يناير 2026 تعديل.xlsm

اعتقد العمل ادناه ( نموذجي / مرن ) هذا ما امكنني الوصول اليه Private Sub SetRating(v As Integer) If Me.MyRating = v Then Me.MyRating = 0 Else Me.MyRating = v End If Me.Dirty = False End Sub Private Sub btnStar1_Click() SetRating 1 End Sub Private Sub btnStar2_Click() SetRating 2 End Sub Private Sub btnStar3_Click() SetRating 3 End Sub Private Sub btnStar4_Click() SetRating 4 End Sub Private Sub btnStar5_Click() SetRating 5 End Sub لتقييم النجوم2.rar

استخدم هذا <><><><><><><> Private Sub btnStar1_Click() If Me.MyRating = 1 Then Me.MyRating = 0 Else Me.MyRating = 1 End If Me.Dirty = False End Sub Private Sub btnStar2_Click() If Me.MyRating = 2 Then Me.MyRating = 1 Else Me.MyRating = 2 End If Me.Dirty = False End Sub Private Sub btnStar3_Click() If Me.MyRating = 3 Then Me.MyRating = 2 Else Me.MyRating = 3 End If Me.Dirty = False End Sub Private Sub btnStar4_Click() If Me.MyRating = 4 Then Me.MyRating = 3 Else Me.MyRating = 4 End If Me.Dirty = False End Sub Private Sub btnStar5_Click() If Me.MyRating = 5 Then Me.MyRating = 4 Else Me.MyRating = 5 End If Me.Dirty = False End Sub

اليك الملف البحث في القائمة بالحروف.xlsm

هذا افضل فلا يمكن معالجة مشكلة إلا في نفس بيئتها

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

ينفع كذا باش مهندس ؟

تحفيزاً .. سأقوم بطرح فكرتي التي تمت من خلال مجموعة التحديات التي تقام كل فترة بين أعضاء مجموعة "مجتمع آكسيس جروب" على الواتس أب .. التحدي 10 _ التقييم 5 نجوم.zip

العفو أخي الكريم .. يسعدنا أن تستفيد من المعلومة بشكل أكبر من الحلول الجاهزة التي ستتعرض لها مستقبلاً , جميع الجهود مشكورة لمن يحاول المساعدة . ولكن بنظري أن تصحيح المسار أفضل من السير في تعرج

بحسب الصورة والذي فهمته منها أنه يجب أن يكون عندك 4 قواطر 1 بترول 2 بترول 1 ديزل 2 ديزل ويجب أن يكون القراءة الحالية لأي يوم تساوي السابقة لليوم الذي بعده لا يكون هناك فرق في العدادات والصورة تظهر مشكلة فرق في القاطرة 2 بترول دعني أشرح لك ( وأنت بالتأكيد فاهم شغلك تمام ولكن لازم نفهم نحن شغلك علشان نساعدك في حل المشكلة حسب الصورة تابع معي سلوك القاطرة (مثلا) 1 بترول في يوم 1/10/2025 السابق 500 والحالي 1500 القاطرة قبل تحركها كانت 500 وبعد ما وصلت 1500 (تمام) في يوم 4/10/2025 السابق 1500 والحالي 2800 ( تمام) القاطرة قبل تحركها كانت 1500 وبعد ما وصلت 2800 (تمام) لا حظ الأن أن الرقم 1500 كان الحالي في 1/10 وأصبح السابق في 4/10 والى الآن كل شيء معقول , ولكن ولكن ! =========== عند تطبيق نفس المنطق السابق على القاطرة 2 بترول يظهر خطأ في يوم 1/10/2025 السابق 250 والحالي 2500 القاطرة قبل تحركها كانت 250 وبعد ما وصلت 2500(تمام) في يوم 4/10/2025 السابق 2800 والحالي 5600( خطأ ) القاطرة قبل تحركها كانت 2800 وبعد ما وصلت 5600 (خطأ ) لا حظ الأن أن الرقم 2500 كان الحالي في 1/10 ولم يصبح السابق في 4/10 بل أصبح 2800 وهذا يدل على وجود فارق 300 (هنا المشكلة) تقبل تحياتي

السلام عليكم السبب هو وجود مسافات قبل الارقام وهذا يحدث عادة عند نسح ارقام ناتجة عن معادلات الحل كل القيم تتحول إلى نصوص (CStr) وتُزال الفراغات (Trim) وهذا يضمن التطابق حتى لو كانت القيم أرقام أو نصوص أو ناتجة عن معادلات. اليك الكود المعدل Sub تحويل_اللجان_الى_اسماء_Turbo() Dim ws As Worksheet: Set ws = ActiveSheet Dim r As Long, c As Long Dim lastRowMain As Long, lastRowSearch As Long Dim رقم_اللجنة As String, اسم_اللجنة As String, اسم_المراقب As String Dim فارق_الاعمدة As Long: فارق_الاعمدة = 12 Dim cell As Range lastRowSearch = ws.Cells(ws.Rows.Count, "N").End(xlUp).Row ws.Range("P3:X" & lastRowSearch).ClearContents lastRowMain = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row lastRowSearch = ws.Cells(ws.Rows.Count, "N").End(xlUp).Row For r = 3 To lastRowMain اسم_المراقب = Trim(CStr(ws.Cells(r, "B").Value)) For c = 4 To 12 رقم_اللجنة = Trim(CStr(ws.Cells(r, c).Value)) If رقم_اللجنة <> "" Then For Each cell In ws.Range("C3:C" & lastRowMain) If Trim(CStr(cell.Value)) = رقم_اللجنة Then اسم_اللجنة = Trim(CStr(ws.Cells(cell.Row, "B").Value)) Dim صف_المراقب As Range For Each صف_المراقب In ws.Range("N3:N" & lastRowSearch) If Trim(CStr(صف_المراقب.Value)) = اسم_المراقب Then ws.Cells(صف_المراقب.Row, c + فارق_الاعمدة).Value = اسم_اللجنة Exit For End If Next صف_المراقب Exit For End If Next cell End If Next c Next r End Sub

السلام عليكم حسب قهمي للكود الكود يتعامل مع العمود A والذي به ترقيم والمفترض التعامل مع الاسماء في العمود B اذا كان فهمي للامر صحيح اليك الكود المعدل والا قم بتوضيح الامر اكثر تصوري Sub Compare2() Dim lr As Long, i As Long, j As Long Dim strCol As String Dim WS As Worksheet: Set WS = Worksheets("Data") Dim hasMissing As Boolean: hasMissing = False Application.ScreenUpdating = False On Error Resume Next lr = WS.Columns("B").Find(What:="*", SearchDirection:=xlPrevious).Row On Error GoTo 0 If lr < 6 Then Application.ScreenUpdating = True Exit Sub End If For i = 6 To 18 strCol = Split((WS.Columns(i).Address(, 0)), ":")(0) Dim lastInCol As Long lastInCol = WS.Cells(WS.Rows.Count, strCol).End(xlUp).Row If lastInCol < 6 Then lastInCol = 6 For j = 6 To lr If WorksheetFunction.CountIf(WS.Range(strCol & "6:" & strCol & lastInCol + 500), WS.Range("B" & j)) = 0 Then With WS.Cells(WS.Rows.Count, strCol).End(xlUp).Offset(1) .Value = WS.Range("B" & j).Value End With hasMissing = True lastInCol = lastInCol + 1 End If Next j Next i Application.ScreenUpdating = True End Sub

هذا اذا استعملت الكود كاملا !! رجاء انظر الى الرابط الذي وضعته في مشاركتي الاولى ، وهذا كود عمل Vcard الموجود هناك ، ولكني استعملت حقول الاسم الاول ومكان العمل ورقم الهاتف وتاريخ الميلاد فقط ، واوفقت الباقي (بهذه الطريقة انت اختار الحقل اللي تريدها) : Function Add_Items() Dim VCard_Text As String 'clear field VCard_Text = "" VCard_Text = "BEGIN:VCARD" & vbCrLf VCard_Text = VCard_Text & "VERSION:3.0" & vbCrLf ' VCard_Text = VCard_Text & "N:" & Me.[Family Name] & ";" & Me.[Given Name] & ";" & Me.[Additional Name] & ";" & Me.[Name Prefix] & ";" & vbCrLf VCard_Text = VCard_Text & "FN:" & Me![Name] & vbCrLf VCard_Text = VCard_Text & "ORG:" & Me.[Organization 1] & vbCrLf VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 1 - Type] & ",VOICE:" & Me.[Phone 1 - Value] & vbCrLf ' VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 2 - Type] & ",VOICE:" & Me.[Phone 2 - Value] & vbCrLf ' VCard_Text = VCard_Text & "TEL;TYPE=" & Me.[Phone 3 - Type] & ",VOICE:" & Me.[Phone 3 - Value] & vbCrLf ' VCard_Text = VCard_Text & "ADR;:" & ";;" & Me.[Address 1] & ";;;;" & vbCrLf VCard_Text = VCard_Text & "BDAY:" & Me.[Birthday] & vbCrLf ' VCard_Text = VCard_Text & "EMAIL;TYPE=" & Me.[E-mail 1 - Type] & ":" & Me.[E-mail 1 - Value] & vbCrLf ' VCard_Text = VCard_Text & "EMAIL;TYPE=" & Me.[E-mail 2 - Type] & ":" & Me.[E-mail 2 - Value] & vbCrLf ' VCard_Text = VCard_Text & "NOTE:" & Me.Notes & vbCrLf ' VCard_Text = VCard_Text & "URL:" & Me.[Website 1] & vbCrLf VCard_Text = VCard_Text & "END:VCARD" Add_Items = VCard_Text End Function

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

التوفيق للجميع ان شاء الله استاذي العزيز 🌹 زر البحث موجود بالقاعدة التي تم تحميلها مسبقاً ☝️ ويكون البحث مخصص لسجلات موظف معين في النماذج الفرعية

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

تم بحمد الله تعالى تثبيت نسخة واتس أب على نسخة ويندوز سيرفر 2022 ،، وسأقوم بشرح الخطوات كاملةً بعد رفع جميع المستلزمات التي تم تثبيتها ..

طيب استخرج المجلد بجوار القاعدة ثم استخدم هذا الكود Sub ExportReports_To_OnePDF_PDFtk() Dim arrReports As Variant Dim i As Integer Dim strTempFolder As String Dim strFinalPDF As String Dim strPDFtk As String Dim strCmd As String strPDFtk = CurrentProject.Path & "\PdftkBuilderPortable\pdftk.exe" strTempFolder = CurrentProject.Path & "\TempPDF\" strFinalPDF = CurrentProject.Path & "\AllReports.pdf" arrReports = Array("rpt1", "rpt2", "rpt3") If Dir(strTempFolder, vbDirectory) = "" Then MkDir strTempFolder End If If Dir(strTempFolder & "*.pdf") <> "" Then Kill strTempFolder & "*.pdf" End If For i = LBound(arrReports) To UBound(arrReports) DoCmd.OutputTo acOutputReport, arrReports(i), acFormatPDF, _ strTempFolder & (i + 1) & "_" & arrReports(i) & ".pdf", False Next i strCmd = """" & strPDFtk & """ " & _ """" & strTempFolder & "*.pdf"" cat output " & _ """" & strFinalPDF & """" Shell strCmd, vbHide MsgBox "تم إنشاء ملف PDF واحد بنجاح ?" & vbCrLf & strFinalPDF, vbInformation Kill strTempFolder & "*.pdf" End Sub PdftkBuilderPortable.rar

تفضل السمكة بالهناء والشفاء حساب مع الترتيب حسب المديونية رغم أني لا أفهم شيء في المحاسبة عملاء جديد.xlsb

قد تستفيد من هذ الملف 🙂 : (( للعلم وكما ذكر الباش مهندس فادي @Foksh كان هذا الموضوع هو عنوان تحدي مجموعة الأكسس ، وكانت هناك عدة مشاركات لمختلف الأعضاء وكانت هذه مشاركتي المتواضعة 🙂 )) موسى الكلباني- التتحدي 10 _ التقييم 5 نجوم.accdb

تمام ......... زادك الله من علمه وبارك فيك والف شكر

لما لا تستخدم مسح البيانات القديمة وادراج الجديد

تفضل لتقييم 5 نجوم.rar

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

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

انا مستغرب ما دام هو عميل لماذا لا يستخدم api

وعليكم السلام ورحمة الله وبركاته.. هل تقصد كهذه الفكرة على سبيل المثال :-

كما ذكر الاخ @Foksh فالسبب مرتبط بالويندوز نفسه عموما وجدت لك فيديو يشرح طريقة تحميل واتساب على نفس نسخة الويندوز إن شاء الله تنجح معك رابط الفيديو ومرفق لك ملف مضغوط يحتوي على الملفات المطلوبة في الفيديو قم بنسخ الإصدارات المتوافقة مع جهازك تحياتي LTSC-Add-MicrosoftStore-2024-main.zip

جزاك الله خير الجزاء الحل جميل جدا وهذا هو المطلوب الف شكر لك يالغالي

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

بارك الله فيك لا اعرف كيف يتم الشكر لهذا الجود من استاذنا / عبدالله بشير بارك الله في عمرك

جرب التعديل التالي test2.xlsm

حسب فهمي لسؤالك في الكود المعدل الكود يقرأ عمود التاريخ كرقم وللتوضيح اكثر التواريخ هي في الأصل أرقام (مثلاً تاريخ اليوم هو رقم مثل 46040)، والتنسيق الذي تراه dd/mm/yyyy هو مجرد "قناع" أو مظهر خارجي لتسهيل القراءة علينا كبشر. في الكود توجد الدالة CDbl(.Range("J3").Value)، بحيث يأحد "القيمة الرقمية" الحقيقية المخزنة داخلها. وباحتصار الكود الآن يرى التاريخ كقيمة رقمية مجردة، بغض النظر عن طريقة تنسيق التاريخ في خلايا الجدول (سواء كانت yyyy/mm/dd أو dd-mm-yy). ويمكنك تجربة تبديل بعض التواريح بتغيير التنسيق في الجدول كمثال جعل 15/04/2026 الى 04/15/2026 فالنتيجة واحدة تحياتي

بارك الله فيك Tutuapp 9Apps

عندي سؤال آخر عند استخدام عمود التاريخ للتحقق هل يقرأه كتنسيف dd/mm/yyyy أم كرقم؟ لأن المتغير عرفناه كرقم تاريخ وليس كتنسيق تاريخ

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

السلام عليكم جرب التعديل التالي Sub sav_PDFall() Dim i As Integer Dim folderPath As String Dim mainSheet As Worksheet Dim tempWorkbook As Workbook Dim firstRun As Boolean Set mainSheet = ThisWorkbook.ActiveSheet folderPath = ThisWorkbook.Path & "\ملاحظةالثانوية 2026" firstRun = True If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If Application.ScreenUpdating = False For i = 1 To mainSheet.Range("j3").Value mainSheet.Range("j2") = i If firstRun Then mainSheet.Copy Set tempWorkbook = ActiveWorkbook firstRun = False Else mainSheet.Copy After:=tempWorkbook.Sheets(tempWorkbook.Sheets.Count) End If Next i tempWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=folderPath & "\كشف_جامع_" & mainSheet.Cells(2, 4).Text & ".pdf", _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=True tempWorkbook.Close SaveChanges:=False Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته المشكلة الأساسية في الكود تكمن في طريقة التعامل مع تنسيق التاريخ. في VBA، عندما نستخدم SumIfs مع التواريخ، يفضل تمرير التاريخ كقيمة رقمية (Long) اذا كانت الكميات ارقام صثحيحة و Double بدلاً من Long تحسباً لوجود كسور في الكميات (إذا كانت الكمية تحتوي على فواصل عشرية ) ، لأن تحويله إلى نص (String) مثل "MM/dd/yyyy" قد يتسبب في عدم تطابق البيانات إذا كان إعداد التاريخ في الجهاز مختلفاً. جرب التعديل بالملف المرفق SUMIFS_VBA.xlsm

خالص الشكر على الابداع والتميز

سلمت يمينك استاذنا الغالي .. وشكراً جزيلاً لسعة صدرك 🌹🌹

انظر هذا الموضوع يشتمل على اكثر من حل وطريقة https://www.officena.net/ib/topic/86131-ترقيم-تلقائي-فى-النماذج/#elShareItem_541410426_menu

السلام عليكم بعض الاجهزة لا تقرأ الـ QR العربي (مو عربي فقط ، وانما ما يقرأ Unicode ، ما يقرأ اي لغة غير الانجليزي/اللاتيني) ، ولا يمكن تعديل هذا الشيء في الجهاز!! فاذا طلبك عمل QR انجليزي فقط ، فتأكد من عدم استخدام الامر eci=24 عند عمل QR : .

وعليكم السلام ورحمة الله وبركاته جرب الكود ويوضع في THISWORKBOOK Private Sub Workbook_Open() Dim ws As Worksheet Application.DisplayFullScreen = True Application.DisplayFormulaBar = False For Each ws In ThisWorkbook.Worksheets ws.Activate With ActiveWindow .DisplayHeadings = False .DisplayGridlines = False End With Next ws End Sub

وعليكم السلام ورحمة الله وبركاته جرب الكود حيث قبل التنفيذ، يقوم بحذف أي دوائر سابقة 1الثالث.xlsb

هل تقصد كهذه الفكرة ؟؟ لاحظ شريط التحرير والتنسيق في الصورة !!

و عليكم السلام ورحمة الله وبركاته __اصناف مشتريات - نسخة2.xlsx

السلام عليكم حقيقة الدحول الى الموقع اصبح بالصدفة قليل ما تجدة يعمل الكود سليم والمشكلة في تنسيق الأرقام قي صفخة table في العمودين b& e اذا اردتها بالأرقام العربية حسب ملفك فقم بتنسيقها الى [$-,201]# وان اردتها بالأرقام الغربية اجعل النتسيق رفم بدون خانات عشرية ملف بتنسيق الارقام العربية [$-,201]# مراقبة ثانوية 2026.xlsm ملف بتنسيق الارقام الغربية مراقبة ثانوية1 2026.xlsm

جرب هذا الحل تسجيل الطرمبات2.xlsx

هذه الصور تبين النتيجة تصميم ثم عرض .. العرض يتم لجميع الطلاب