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

السلام عليكم مشاركه مع اخوتى واساتذتى جزاهم الله عنا خيرا بطريقه اخرى عن طريقه اخى واستاذى وشيخنا الجليل @ابوخليل test 110.accdb

اخي العزيز الغالي ابو بسملة .. جميلة جدا هذه الاستعارة .. في ردي السابق نسيت ان اربط النموذج بالبيانات .. تجدون ادناه تعديل لمرفقي السابق test12.rar

اخوي احمد .. الله يكون بعونك .. ستتعب كثيرا test11.rar

وعليكم السلام ورحمة الله وبركاته ,, اخي الكريم انت استخدمت الدالة DLookup لجلب رقم المقترض ( على ما أعتقد ) بناءً على اسم الموظف في الكومبوبوكس ، هل هذا صحيح ؟؟ وبإمكانك بدلاً من ذلك استخدام نفس مصدر الكومبوبوكس com1 ولكن هنا سنختار العمود رقم 2 حيث :- ( العمود 0 = اسم الموظف ، والعمود 1 = الجهة ، والعمود 2 = رقم المقترض ) ، لذا تم استبدال الجملة التالية :- Me.n2 = DLookup("[num]", "karz", "nam LIKE '*" & Me.com1 & "*'") بالجملة :- Me.n2 = com1.Column(2) أيضاً تم إجراء تعديل بسيط على عدد الأعمدة في الكومبوبوكس com1 وعرض كل عمود ؛ كما في الصورة :- الملف بعد التعديل القرضة الحسنة اصدار 31.zip

الاخ العزيز Foksh جزاك الله خير الجزاء ما قمت به هو المطلوب تماما

اعتذر اختي الكريمه على عدم الرد ، بسبب العمل من جهة ، ومن جهة أخرى عند قراءة الكود لاحظت تكرار الحلقة For A = 1 To 1 وأعتقد انك لست بحاجة لتكرارها وقد يكون هناك إمكانية لتنفيذ الحلقه التكرارية مرة واحدة على ما أعتقد. كل الاحترام والتقدير لشخصك الكريم 😇

كده يعنى test 10.accdb

الكود يرتب ابجدي ويحذف التكرار Private Sub UserForm_Initialize() Dim ws As Worksheet Dim rng As Range Dim data As Variant Dim sortedData As Variant Dim uniqueData As Collection Dim i As Long, j As Long Dim temp As Variant Set ws = ThisWorkbook.Sheets("Sheet3") Set rng = ws.Range("D2:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row) data = rng.Value ReDim sortedData(1 To UBound(data, 1), 1 To 1) For i = 1 To UBound(data, 1) sortedData(i, 1) = data(i, 1) Next i For i = 1 To UBound(sortedData, 1) - 1 For j = i + 1 To UBound(sortedData, 1) If sortedData(i, 1) > sortedData(j, 1) Then temp = sortedData(i, 1) sortedData(i, 1) = sortedData(j, 1) sortedData(j, 1) = temp End If Next j Next i Set uniqueData = New Collection On Error Resume Next For i = 1 To UBound(sortedData, 1) uniqueData.Add sortedData(i, 1), CStr(sortedData(i, 1)) Next i On Error GoTo 0 With Me.ComboBox1 .Clear For i = 1 To uniqueData.Count .AddItem uniqueData(i) Next i End With With Me.ComboBox2 .Clear For i = 1 To uniqueData.Count .AddItem uniqueData(i) Next i End With End Sub الملف ترتيب البيانات ابجديا.xlsm

Sub SaveAs_PDF() Dim NAME1 As String, NAME2 As String, NAME3 As String Dim Path As String, fname As String, FullPath As String Dim response As VbMsgBoxResult NAME1 = Range("B2").Value NAME2 = Range("B3").Value NAME3 = Range("B4").Value Path = "D:\PDF\" If Dir(Path, vbDirectory) = "" Then MkDir Path End If fname = NAME1 & " - " & NAME2 & " - " & NAME3 & ".pdf" FullPath = Path & fname If Dir(FullPath) <> "" Then response = MsgBox("الملف موجود بالفعل هل تريد استبداله؟", vbYesNo + vbQuestion, "تأكيد") If response = vbNo Then Exit Sub End If End If ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FullPath, IgnorePrintAreas:=False MsgBox "Saved As PDF " End Sub TEST SAVE PDF.xlsb

جزيل الشكر والامتنان استاذنا الفاضل جعله الله تعالى في ميزان حسناتكم

والله رائع جدا جدا أخى الكريم الفاضل / محمد هشام كود ولا أروع ***** بارك الله فيكم وجزاكم الله خيرا

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة النتائج على الملف المرفق لاحظت انك ترغب بحساب الفرق بين التواريخ بطرق مختلفة خاصة طريقة حساب عدد الشهور لهدا سنقوم بدمج الدوال الخاصة بك في دالة واحدة مع بعض التعديلات للحصول على نفس النتائج الموجودة على عمود k CalcAge تحسب الفرق بين تاريخين (vDate1 و vDate2) بطريقة تقليدية CalcAgey2 تستخدم DateDiff Option Explicit Dim Cnt As Boolean Function CalcAge(vDate1 As Variant, vDate2 As Variant, ByVal resultType As String) As Variant Dim vYears As Integer, vMonths As Integer, vDays As Integer If IsEmpty(vDate1) Or IsEmpty(vDate2) Then CalcAge = "" Exit Function End If If Not IsDate(vDate1) Or Not IsDate(vDate2) Then CalcAge = CVErr(xlErrValue) Exit Function End If If vDate2 < vDate1 Then If Not Cnt Then MsgBox "التاريخ الثاني يجب أن يكون أكبر من الأول" Cnt = True End If CalcAge = CVErr(xlErrValue) Exit Function End If Cnt = False ' حساب الفرق في السنوات والأشهر والأيام vYears = Year(vDate2) - Year(vDate1) vMonths = Month(vDate2) - Month(vDate1) vDays = Day(vDate2) - Day(vDate1) If vDays < 0 Then vMonths = vMonths - 1 Dim lastMonth As Date lastMonth = DateAdd("m", -1, vDate2) vDays = Day(DateSerial(Year(lastMonth), Month(lastMonth) + 1, 1) - 1) + vDays End If If vMonths < 0 Then vYears = vYears - 1 vMonths = vMonths + 12 End If Select Case resultType Case "Days" CalcAge = vDays Case "Months" CalcAge = vMonths Case "Years" CalcAge = vYears Case "Days and Months" CalcAge = vDays & " Days and " & vMonths & " Months" Case "Years and Months" CalcAge = vYears & " Years and " & vMonths & " Months" Case "Total" CalcAge = vDays & ", " & vMonths & ", " & vYears Case Else CalcAge = "صيغة الدالة غير معروفة" End Select End Function Function CalcAgey2(vDate1 As Variant, vDate2 As Variant, ByVal resultType As String) As Variant If IsEmpty(vDate1) Or IsEmpty(vDate2) Then CalcAgey2 = "" Exit Function End If If Not IsDate(vDate1) Or Not IsDate(vDate2) Then CalcAgey2 = CVErr(xlErrValue) Exit Function End If ' حساب الفرق في الأشهر Dim totalMonths As Integer totalMonths = DateDiff("m", vDate1, vDate2) Dim vDays As Integer vDays = DateDiff("d", DateAdd("m", totalMonths, vDate1), vDate2) If vDays < 0 Then totalMonths = totalMonths - 1 vDays = DateDiff("d", DateAdd("m", totalMonths, vDate1), vDate2) End If Dim vYears As Integer vYears = totalMonths \ 12 Dim vMonths As Integer vMonths = totalMonths Mod 12 Select Case resultType Case "Years" CalcAgey2 = vYears Case "Months" CalcAgey2 = totalMonths Case "Years and Months" CalcAgey2 = vYears & " Years and " & vMonths & " Months" Case "Days" Dim totalDays As Integer totalDays = DateDiff("d", vDate1, vDate2) CalcAgey2 = totalDays Case "Months and Days" CalcAgey2 = totalMonths & " Months and " & vDays & " Days" Case "Total" CalcAgey2 = vDays & ", " & vMonths & ", " & vYears Case Else CalcAgey2 = CVErr(xlErrValue) End Select End Function عدد الأيام =CalcAge(A3, B3, "Days") عدد الشهور =CalcAge(A3, B3, "Months") عدد السنوات =CalcAge(A3, B3, "Years") عدد الشهور الطريقة 2 =CalcAgey2(A3, B3, "Months") حساب السنوات والشهور =CalcAge(A3, B3, "Years and Months") حساب الايام والشهور =CalcAge(A3, B3, "Days and Months") حساب الفرق بين تاريخين v1.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هذا Sub SaveAs_PDF() Dim NAME1 As String Dim NAME2 As String Dim NAME3 As String Dim Path As String Dim fname As String NAME1 = Range("B2").Value NAME2 = Range("B3").Value NAME3 = Range("B4").Value Path = "D:\PDF\" 'إنشاء مجلد الحفظ في حالة عدم وجوده ' If Dir(Path, vbDirectory) = "" Then ' MkDir Path ' End If fname = NAME1 & " - " & NAME2 & " - " & NAME3 & ".pdf" MsgBox "Saved as PDF" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & fname, IgnorePrintAreas:=False End Sub مع التأكد من تفعيل المراجع الأساسية على مكتبة vba مثل: Visual Basic For Applications Microsoft Excel Object Library

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

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

السلام عليكم ارجو ان اكون فهمت المطلوب بالطريقة الصحيحة 🙂 1618.Cal error2.accdb.zip

طيب وبعد التحليل للمرفق ومن غير اى اكواد ممكن جملة الاستعلام دى تحل لك كل مشاكلك SELECT Table1.code, Table1.test, Table1.result, Table2.Cal, Nz([result], 0)/Nz([Cal], 1) AS FinalCalc FROM Table1 INNER JOIN Table2 ON Table1.code = Table2.code; وما اخدت بالى من موضوع التقريب لو اردنا استخدام التقريب تكون جملة الاستعلام بالشكل التالى SELECT Table1.code, Table1.test, Table1.result, Table2.Cal, IIf(Nz([result], 0) <> 0 And Nz([Cal], 1) <> 0, Round(Nz([result], 0) / Nz([Cal], 1), 3), Nz([result], 0) / Nz([Cal], 1)) AS FinalCalc FROM Table1 INNER JOIN Table2 ON Table1.code = Table2.code; وهذا هو المرفق انظر الى الاستعلام مباشرة وغير القيم فى الحقل Cal تظهر لك النتيجة المرجوة مباشرة فى الحقل FinalCalc دا اذا كنت قدرت افهم انت عاوز ايه Cal error.accdb

انا اللي فاهم على صاحب الموضوع هو يريد تنفيذ (تشغيل) كود مكتوب في الجدول لهذا وجهته ان هذه الطريقة ستسبب له لاحقا مشاكل برمجية .. وايضا فيها محاذير أمنية . على كل حال انت صاحب الشان جرب هذا Dim x As String x = DLookup("cal", "test_tbl") Me.C = Round(Eval(x), 3) Cal error2.rar

نعم، وعليه كتبت ملاحظاتي. والان حسب مرفقك الثاني ، هل هذا اللي تريده: بمعنى انك تريد ان يظهر لك في Table2 هذه النتائج ؟

بدلا من كتب المعادلة في الجدول اعمل في الجدول عمود بـــــ المعادلة1 / المعادلة2 / المعادلة3 .. الخ .. وعمود بجانبه رقمي يمثل معرف في محرر الفيجوال اعمل فنكشن : اذا قيمة الحقل الفلاني في الجدول الفلاني = 1 نفذ هذا السطر واذا القيمة = 2 نفذ السطر الآخر هذا وهكذا ... لو تعمل 100 سطر اتمنى شرحي واضح ومفهوم

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

مرفق ملف للترجمه بواسطه السيلينيوم * لابد من تصطيب السيلينيوم ويمكنك تحميله من هذا الرابط * وتحديث درايفر الكروم من هذا الرابط Translator.xlsm

السلام عليكم ورحمة الله وبركاته اخوانى الاعزاء تحية طيبة ،،،،، االيوم جايبلكم طريقة جميلة لغلق الفورم اتمنى ان يحوز اعجابكم (اغلاق الفورم من اليمين ثم لاسفل ) انتظر ارائكم konafa4000 اغلاق الفورم بطريقة جميلة.rar

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

السلام عليكم ورحمة الله جرب أن تبدل في التسميات من Col_1 إلى Col_8 الجزئية التالية من معادلاتها : COUNTA(AliElmasry2!$L$7:$L$17) بالجزئية التالية: SUMPRODUCT((AliElmasry2!$L$7:$L$17<>"")*(AliElmasry2!$L$7:$L$17<>" ")) وتبديل في معادلات التسميتين Plage1 و Plage2 الجزئية التالية: COUNTA(AliElmasry2!$L$6:$L$17) بالجزئية التالية: SUMPRODUCT((AliElmasry2!$L$6:$L$17<>"")*(AliElmasry2!$L$6:$L$17<>" ")) إذا لم تنفع الفكرة أرسل لي الملف عبر الخاص لأحاول إيجاد للمشكلة... بن علية حاجي

السلام عليكم ألق نظرة على النطاقات الديناميكية المضافة بالتسميات وعلى خاصية "تحديد البيانات" للرسم لمعرفة كيفية ربط بيانات الرسم بالتسميات التي تم إنشاؤها... ملاحظة: تم حذف كل التسميات الأخرى من الملف ماعدا التسمية AliLang لتسهيل معرفة التسميات التي تم إضافتها... بن علية حاجي Dynamic Range.rar

الإخوة الأعزاء , لقد استفدت ايما فائدة من هذا المنتدى , جزى الله عنا اخواننا خير الجزاء الفكرة : جمع الاكواد التي غالبا ما اتعامل بها في برامجي ووضعها في ملف وربطها بصورة ظريفة وجذابة بحيث يمكن الرجوع لهذه الاكواد في اي وقت المشروع مفتوح ويمكن لاي شخص ان يضيف له ما شاء من الافكار والاكواد المفيدة وكتابة وصفها في مشاركته لتسهيل عملية البحث ويظل مثل حقيبة المجوهرات . فعندما يبحث احدنا عن الاتي : - كود لإخفاء الريبون Ribbon أو إخفاء شريط الحالة Statusbar والشيت Sheet tabs - كود لإغلاق الخلايا Lock area ( وليس حمايتها ) من التعديل ما عدا التي تحددها انت . - كود لإخفاء اشرطة التمرير Scroll bars وتعطيل عجلة الماوس Mouse wheel - كود لمربع النص بان لا يقبل اي حرف او رمز الا الأرقام فقط Numeric - كود بان لا يغلق الاكسل الا بعد التحقق من شيء معين - اكواد مقارنة القيم واظهار الرسائل المختلفة . ...... الخ كلها سيجدها هنا مفصلة اتمنى ان تنال الفكرة اعجابكم خاصة المبتدئين امثالي اسألكم الدعاء وشكرا , أخوكم : الفدائي __________________________________________ Electronic-Beggar.zip

بارك الله فيك أخى وأستاذى ياسر وهذا كود أخر لحفظ مدى محدد بصيغة PDF Sub Save_Range_As_PDF() ActiveSheet.Range("A1:h53").ExportAsFixedFormat Type:=xlTypePDF, _ Filename:="H:\Test pdf File.pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True End Sub غير الاسم والمسار الى ما تحب طبقت الكود على المرفق مثال بس غيرت اسم الملف فقط حفظ مدى محدد بصيغة PDF.rar

أخي الفاضل مروان إنت ليه عملت حساب جديد !! كان من المفترض إنك تعدل الحساب القديم وتغير اسم الظهور فقط عموما بالنسبة لطلبك في منتهى البساطة ..لو إنت عايز صفحة واحدة فقط من صفحات ورقة العمل .. تحدد النطاق للصفحة الأولى المراد عمل تصدير لها وتروح للتبويب Page Layout ثم تختار Print Area ثم تختار Set Print Area وأخيراً نفذ الكود صراحة حاولت في ملفك ولكن يبدو أن الملف به أمر غير طببيعي ولم أدرك ما هي مشكلته فقمت بتجربة الكود في ملف مرفق من عندي ليتضح لك أنه يمكنك تصدير صفحة واحدة فقط من صفحات ورقة العمل Save First Page Of Worksheet As PDF.rar

أخي الحبيب غسان إليك الملف المجاني .. وعيوني للأخوة الأعضاء Functions 2013-EN-US (free-unlocked).rar

السلام عليكم ورحمة الله أخي الكريم، قمت ببعض التغييرات على ملف أخي الحبيب محمود الذي أرفقه في الرد رقم 6... حيث اختصرت التسميات صف2، صف3، ... الخاصة باالنطاقات Sheet1!$A$2:$D$2ـ Sheet1!$A$3:$D$3... إلى تسمية واحدة "صف" لنطاق متغير Sheet1!$A1:$D1 (متغير حسب رقم السطر) وحجزت المعادلة : =IF(INDEX(صف;ROWS(الراتب)-ROW(INDIRECT("a"&COLUMN()-1))+1)="";"";INDEX(صف;ROWS(الراتب)-ROW(INDIRECT("a"&COLUMN()-1))+1)) في الخلية M2 ثم نسخها إلى آخر الجدول (عناوين الجدول + بياناته)... وهذا تفاديا لتغيير المعادلات في الجدول وإضافة تسميات عديدة (وخاصة لما يكون هذا الجدول كبيرا بعدد صفوفه) تجد كل ذلك في الملف المرفق... أخوكم بن علية عكس جدول بالمعادلات_2.rar

السلام عليكم مرفق ملف فيه شرح لمعادلات الاكسل وهو مشابه لعمل الاستاذ الفاضل جمال الفار الملف المرفق (مفتوح) EXCEL_Formulae01(1).rar

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

أخي العزيز السلام عليكم ورحمة الله وبركاته أرجو الاطلاع على المرفق وبه 3 أكواد لتحويل الملف بالكامل أو أوراق معينة تقوم بتنشيطها أو نطاق معين تقوم باختياره لصيغة ملفات PDF أرجو أن يناسب طلبك . تحياتي أبو عبدالله تحويل الملف بالكامل أو الصفحة النشطة أو نطاق تختاره إلى ملف PDF.rar

السلام عليكم قمت بالتعديل بحيث انه يقوم بحفظ خلايا بمدى ملائم للشرت ويقوم بحذف الشرت بعد حفظ الصورة بدون اظهار رسالة الاكسل لتاكيد الحذف ويتم حفظ الصورة في فولدر ملف الاكسل هذا بشكل سريع وساقوم بالتعديل بطرق اخرى Sub Export_Range_Images() ' ========================================= ' Code to save selected Excel Range as Image ' ========================================= Dim P Dim oRange As Range Dim oCht As Chart Dim oImg As Picture P = ActiveWorkbook.Path & "\" Set oRange = Range("A1:O35") Set oCht = Charts.Add Application.ScreenUpdating = False Application.DisplayAlerts = False oRange.CopyPicture xlScreen, xlPicture oCht.Paste oCht.Export Filename:=P & "SavedRange.jpg", Filtername:="JPG" oCht.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub خبور خير حفظ صورة من نطاق خلايا معين.rar