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

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

الاستاذ عبد اللطيف أرجو أن يكون التعديل لجمع الأعداد هو المطلوب جمع الاعداد بعد التعديل.accdb

وعليكم السلام ورحمة الله رمضان مبارك، وتقبل الله منا ومنكم الصلاة والصيام والقيام وصالح الأعمال... تم عمل التعديلات حسب ما فهمت من المطلوب، راجع الملف المرفق إن كان يفي الغرض المنشود... بن علية حاجي BOOK (2).rar

السلام عليكم في بعض الأحيان نحتاج إلى عرض صورة في عمود أو خلية تبعاً لقيمة خلية في عمود آخر أو خلية أخرى مثلاً تغيير صورة منتج بناء على اسمه أو كوده و تغيير صورة موظف مع تغير اسمه الأكواد المستخدمة 'كود إضافة قائمة منسدلة إلى العمود الذي سيتم تغيير الصور بناء على قيمته Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next If Target.Column = 1 Then With Range("a" & Target.Row).Validation .Delete 'w_r=OFFSET($E$1;0;0;COUNTIF($E$1:$E$1000;"<>")) .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=w_r" .IgnoreBlank = True .InCellDropdown = True .ShowInput = True .ShowError = True End With End If End Sub 'إدراج الصور في الخلايا Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Application.ScreenUpdating = False Dim PicM As Picture Dim pictloc As String 'Created by H-E Khalf Dim x As String If Target.Column = 1 And Range("a" & Target.Row) = "" Then x = Range("c" & Target.Row).Address & "c" ActiveSheet.Shapes(x).Delete End If If Target.Column = 1 And Range("a" & Target.Row) <> "" Then x = Range("c" & Target.Row).Address & "c" ActiveSheet.Shapes(x).Delete pictloc = Application.ActiveWorkbook.Path & "\" & Range("a" & Target.Row).Value '& ".jpg" Set PicM = ActiveSheet.Pictures.Insert(pictloc) PicM.Select PicM.ShapeRange.LockAspectRatio = msoFalse PicM.ShapeRange.Height = Range("c" & Target.Row).Height PicM.ShapeRange.Width = Range("c" & Target.Row).Height PicM.Top = Range("c" & Target.Row).Top PicM.Left = Range("c" & Target.Row).Left PicM.Placement = xlMoveAndSize PicM.Name = Range("c" & Target.Row).Address & "c" Range("a" & Target.Row).Select End If Application.ScreenUpdating = True End Sub 'تصفير البيانات Private Sub CommandButton1_Click() Call Del End Sub Sub Del() Application.ScreenUpdating = False Application.DisplayAlerts = False Dim Sh As Excel.Shape For Each Sh In ActiveSheet.Shapes If Right(Sh.Name, 1) = "c" Then Sh.Delete End If Next Dim Cel As Range Dim C As Integer For Each Cel In Range("a1:a1000") With Cel.Validation .Delete .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween .IgnoreBlank = True .InCellDropdown = True .ShowInput = True .ShowError = True End With Next Range("a:a").ClearContents Range("a:a").ClearHyperlinks Selection.ClearContents Selection.ClearHyperlinks Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub ' جلب أسماء الصور من المجلد الذي سيوضع به الملف و هي من لاحقة ' jpg Private Sub Workbook_Open() Call Get_Files_Names End Sub Sub Get_Files_Names() Application.ScreenUpdating = False Application.DisplayAlerts = False Dim fldpath Dim fso As Object, fld As Object, fil As Object, j As Long On Error Resume Next fldpath = Application.ActiveWorkbook.Path If fldpath = False Then MsgBox "Folder Not Selected" Exit Sub End If Columns("D:D").Clear Set fso = CreateObject("Scripting.FileSystemObject") Set fld = fso.getfolder(fldpath) j = 1 For Each fil In fld.Files Range("D" & j).Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=fil.Path, _ TextToDisplay:=fil.Name ActiveSheet.Hyperlinks.Delete j = j + 1 Next Dim Cel As Range For Each Cel In Range("D1:D1000") If Right(Cel, 4) <> ".jpg" Then Cel.Delete Shift:=xlUp End If Next Dim Cel1 As Range For Each Cel1 In Range("D1:D1000") If Left(Cel1, 1) = "~" Then Cel1.Delete Shift:=xlUp End If Next Set fso = Nothing Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub قمت بكتابة بعض هذه الأكواد بينما اقتصر عملي على تعديل بعضها فقط و جزى الله خيراً من قدم الأكواد الأصلية. احتجت إل هذه الفكرة فاحببت مشاركتها مع من يبحث عنها إدراج صورة متغيرة حسب قيمة خلية.xlsm

السلام عليكم ورحمة الله تعالى وبركاته اولا: عملية ربط قاعدة بيانات بمسار محدد توضع حيث يتم وضع قاعدة البيانات التي تحتوي غلي الجداول في نفس مجلد قاعدة الواجهة Autolink Path.rar ---------------------------------------- ثانيا :عملية الربط التلقائي بدون تحديد المسار حيث يتم البحث عن قاعدة البيانات المطلوبة لربط الجداول اينما كانت Autolink Table.rar ---------------------------------------- ثالثا :عملية ربط قاعدة الواجهة باكثر من قاعدة link MultiDB.rar مع اطيب وارق الامنيات بالاستمتاع

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

حبيبي وانت بكل خير

السلام عليكم رمضان كريم على الجميع وجدة هذا الكود الخاص بتفعيل عجلة الماوس لليست بوكس كما وجدة بأنه يعمل كذلك مع الكومبو بوكس فأردت مشاركته اياكم لتعميم الفائدة وانا بصراحة اعجبني حيث انه يصبح من السهل تصفح البينات خاصتا عندما تكون كبيرة كل ما عليكم وضع هذا الكود في موديل عادي Option Explicit Private Type POINTAPI X As Long Y As Long End Type Private Type MOUSEHOOKSTRUCT pt As POINTAPI hwnd As Long wHitTestCode As Long dwExtraInfo As Long End Type Private Declare Function FindWindow Lib "user32" _ Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32.dll" _ Alias "GetWindowLongA" ( _ ByVal hwnd As Long, _ ByVal nIndex As Long) As Long Private Declare Function SetWindowsHookEx Lib "user32" _ Alias "SetWindowsHookExA" ( _ ByVal idHook As Long, _ ByVal lpfn As Long, _ ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function CallNextHookEx Lib "user32" ( _ ByVal hHook As Long, _ ByVal nCode As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" ( _ ByVal hHook As Long) As Long Private Declare Function WindowFromPoint Lib "user32" ( _ ByVal xPoint As Long, _ ByVal yPoint As Long) As Long Private Declare Function GetCursorPos Lib "user32.dll" ( _ ByRef lpPoint As POINTAPI) As Long Private Const WH_MOUSE_LL As Long = 14 Private Const WM_MOUSEWHEEL As Long = &H20A Private Const HC_ACTION As Long = 0 Private Const GWL_HINSTANCE As Long = (-6) Private mLngMouseHook As Long Private mListBoxHwnd As Long Private mbHook As Boolean Private mCtl As MSForms.Control Dim n As Long Sub HookListBoxScroll(frm As Object, ctl As MSForms.Control) Dim lngAppInst As Long Dim hwndUnderCursor As Long Dim tPT As POINTAPI GetCursorPos tPT hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y) If Not frm.ActiveControl Is ctl Then ctl.SetFocus End If If mListBoxHwnd <> hwndUnderCursor Then UnhookListBoxScroll Set mCtl = ctl mListBoxHwnd = hwndUnderCursor lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE) If Not mbHook Then mLngMouseHook = SetWindowsHookEx( _ WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0) mbHook = mLngMouseHook <> 0 End If End If End Sub Sub UnhookListBoxScroll() If mbHook Then Set mCtl = Nothing UnhookWindowsHookEx mLngMouseHook mLngMouseHook = 0 mListBoxHwnd = 0 mbHook = False End If End Sub Private Function MouseProc( _ ByVal nCode As Long, ByVal wParam As Long, _ ByRef lParam As MOUSEHOOKSTRUCT) As Long Dim idx As Long On Error GoTo errH If (nCode = HC_ACTION) Then If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then If wParam = WM_MOUSEWHEEL Then MouseProc = True If lParam.hwnd > 0 Then idx = -1 Else idx = 1 idx = idx + mCtl.TopIndex If idx >= 0 Then mCtl.TopIndex = idx Exit Function End If Else UnhookListBoxScroll End If End If MouseProc = CallNextHookEx( _ mLngMouseHook, nCode, wParam, ByVal lParam) Exit Function errH: UnhookListBoxScroll End Function ثم في حدث MouseMove بالنسبة للكومبوبوكس ضع هذا الكود HookListBoxScroll Me, Me.ComboBox1 اما بالنسبة لليست بوكس في حدث MouseDown ضع هذا الكود HookListBoxScroll Me, Me.ListBox1 وفي الاخير في حدث UserForm_QueryClose ضع هذا الكود UnhookListBoxScroll ارجو ان يفيدكم الموضوع قبل الله صيام الجميع تفعيل عجلة الماوس.rar

وعليكم السلام ورحمه الله اباجودي⁦❤️⁩ الدالة ()now ترجع التاريخ والوقت معا في نفس الحقل ..أما إذا كنت تريد الوقت فقط استخدم الدالة Time فهي تجلب لك الوقت فقط أما بالنسبة لتنسيق الوقت فلم اجرب من قبل موضوع صباحاً ومساء استخدامت فقط AM/PM ..ولكني سوف اجرب أعود لك تحياتي

تم معالجة الامر Option Explicit 'Created by Salim Hasbaya 2/5/2019 Sub New_tarhil() Application.ScreenUpdating = False Dim arr_s(1 To 11) Dim arr_t(1 To 11) Dim i%, RO_Num%, Final_Row% Dim RO_s% Dim RGS As Range Dim source_sh As Worksheet Set source_sh = Sheets("أدخال") 'from Dim target_sh As Worksheet Set target_sh = Sheets("اليومية") 'to '================================= RO_s = source_sh.Cells(Rows.Count, "A").End(3).Row + 1 If RO_s = 6 Then MsgBox "No Data To Transfer": GoTo LEAVE_ME_OUT RO_Num = source_sh.Range("a5"). _ CurrentRegion.Rows.Count Set RGS = source_sh.Range("a5"). _ CurrentRegion.Offset(1).Resize(RO_Num - 1) RO_Num = RGS.Rows.Count Final_Row = target_sh.Cells(Rows.Count, "D").End(3).Row + 1 '========================= For i = 1 To 11: arr_s(i) = i: Next For i = 1 To 3: arr_t(i) = i + 3: Next arr_t(4) = 9: arr_t(5) = 10 For i = 6 To 11: arr_t(i) = i + 8: Next For i = 1 To UBound(arr_s) target_sh.Rows(Final_Row). _ Cells(arr_t(i)).Resize(RO_Num).Value = _ RGS.Cells(1, arr_s(i)).Resize(RO_Num).Value Next Erase arr_t: Erase arr_s LEAVE_ME_OUT: Application.ScreenUpdating = True End Sub File Unclouded SAlim_ Prog_new1.xlsm

السلام عليكم تقبل الله منا ومنكم الصلاة والصيام والقيام وصالح الأعمال.... جرب المرفق لعله يفي الغرض... بن علية حاجي ورقة الإستهلاك اليومي عامة 2013.rar

السلام عليكم عليكم اخواني واخواتي اليوم حاب اقدم لكم برنامج المقارنة بين قاعدتين اكسس طبعا البرنامج معمول بالفجول بيسك للصديق العزيز واخونا الغالي بالعمل المبرمج ابو وديع طبعا البرنامج يقوم بالمقارنه بين قاعدتين اكسس ويقوم بإستخراج الفروقات التاليه الجداول غير الموجوده الحقول المتطابقه الحقول غير الموجوده جداول ليست في القاعده الجديده جداول ليست في القاعده القديمه حقول ليست في القاعده الجديده حقول ليست في القاعده القديمه حقول متطابقه مع اختلاف نوع البيانات وللتحميل من خلال الرابط التالي https://up.top4top.net/downloadf-1236awwgg1-rar.html ولمعرفة كيفية استخدام البرنامج يرجى الدخول على رابط الشرح الموجود بالاسفل

مقارنه_الاكسس.rar

ده حتي ما فى عفاريت فى شهر رمضان

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

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

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

السلام عليكم تفضل إليك هذا المثال به ما تريد إن شاء الله منع تعديل تاريخ الجهاز.rar

بعد البحث عن الخلل وبعد تعب ومشقة للوصول للخطأ في الكود تبين أن الكود يعمل بشكل سليم والخطأ لديك في العمود BB وتم تصويبها تفضل المطلوب الدور الثانى 2019 علمى.xlsm

ملف ممتاز بارك الله فيك أستاذ عادل وزادك الله من فضله وكل عام وانتم بخير

تفضل .. اسماء النماذج والتقارير في مربع تحرير.accdb

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

نسخة الأوفيس بها ملفات ناقصة والله أعلم

السلام عليكم الفرق بينهما هو في الدوال المستعملة فقط وخاصة في الجزئيتين (NB.SI(O:O;">"&O2 و RANG(O2;$O$2:$O$11;0)-1، فالأولى تعدّ عدد القيم الأكبر تماما لكل خلية في العمود O بداية من الخلية O2، بينما الثانية فهي تعطي الترتيب التنازلي (من الأكبر إلى الأصغر) لكل خلية في العمود O بداية من الخلية O2 (مع تكرار بعض الرتب)، ومع -1 في الجزئية الثانية يكون للجزئيتين المعنى نفسه (ما يفسر النتيجة نفسها)، مع العلم أن كلتا الجزئيتين تعطي ترتيبا لقيم العمود O بداية من 0 (الصفر) مع التكرار (في حالة تساوي بعض القيم)... أما الجزئية (NB.SI($O$2:O2;O2 في كلتا المعادلتين فهي لأمرين أولا لاستعادة الترتيب من 1 إلى أعلى رتبة (عدد قيم العمود O) وثانيا لتجنب تكرار الرتب في حالة تساوي بعض القيم من العمود O... والله أعلم أرجو أني وفقت في الشرح... بن علية حاجي

السلام عليكم طريقة اظافة دالة جديدة مستحدثة وتصبح مثل دوال الاكسل الموجودة تتم اولا قم بتح ملف اكسل جديد قم بعمل موديل جديد واحفظ الدالة بداخله واخيرا قم بحفظ الملف بصيغة ادد ان حيث سيكون امتداد الملف هو Microsoft Office Excel Add-In (.xlam) الان قم بفتح اي ملف اكسل اخر واذهب الى خيارات اكسل واختار الخيار السادس الوظائف الاظافية وبعد الدخول الى الوظائف الاظافية في اخر الصفحة الضغط على زر الانتقال حيث سيفتح لك صندوق خيارات وستجد دالتك مسجلة بنفس اسم الملف الذي قمت بحفظة كل ما عليك هو ان تضع اشارة صح عليها ونكون قد انتهينا الان بالذهاب الى الدوال ستجد دالتك موجودة تحت معرفة من قبل المستخدم مرفق دالة للاستاذ ابو تامر وهي دالة vlookanycol تم حفظا بهذا الامتداد جربها لن تخسر شيئا 5.rar

يمكن التحكم بالمدخلات بأكثر من طريقة انظر هذا مثال شامل للحروف العربية والاجنبية والارقام لأخونا الاستاذ القدير يوسف معطي تحديد نوع المدخلات في مربع النص.rar

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

جزاك الله خيراً أستاذ محمد صلاح مشكور على مجهودك

شكرا للاهتمام بالمتابعة وللنصيحة رغم أنها في غير محلها فانا أبحث واتعلم وانفذ بنفسي قدر استيعابي وجهدي فهذا لا خلاف عليه ولكن فوق كل ذي علم عليم هذا بخلاف عامل الوقت الذي لم يعد لصالحي لإنهاء العديد من النقاط والخطوات المتبقية والتي أتعرض لها لأول مرة فمن الطبيعي أن استفسر عما أجهله لأستطيع تطبيقه وإن عجزت عن تطبيقه فمن الطبيعي أيضاً أن أطلب المساعدة في تطبيقه ليصبح العمل جاهزا للاستخدام العام في أقرب وقت بإذن الله التعديل الذي طرحته يختلف عن المطلوب المراد ورغم ذلك لم يحقق المطروح هدفه أيضاً كما يظهر بالصورة المرفقة ودي نصيحتي ليك كما نصحتني: (أخي محمد مش كل الناس شاطره زيك أو ظروفها زي ظروفك) فلا تقيس كل الناس علي نفسك فكلا خلق لما يسر له كما أخبر المصطفي صل الله عليه وسلم