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

Private Sub Worksheet_Change(ByVal Target As Range) Dim sCompany As String, m As Long If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Address = "$D$5" Then sCompany = Target.Value If Evaluate("ISREF('" & sCompany & "'!A1)") Then With Sheets(sCompany) m = .Cells(Rows.Count, "D").End(xlUp).Row + 1 .Range("D" & m).Resize(1, 4).Value = Application.Transpose(Range("M7:M10").Value) MsgBox "Data Copied To [ " & .Name & " ] Worksheet", 64 End With End If End If End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub Transf() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Tmp As Variant Dim LR As Long, LS As Long, i As Long, j As Long, p As Long Set Sh = Sheets("BASS") LR = Sh.Range("B" & Rows.Count).End(3).Row Arr = Sh.Range("A5:E" & LR).Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For Each ws In Worksheets LS = ws.Range("B" & Rows.Count).End(3).Row For i = 1 To UBound(Arr, 1) If Arr(i, 5) = ws.Name Then p = p + 1 For j = 1 To 5 Tmp(p, j) = Arr(i, j) Next End If Next If p > 0 Then ws.Range("A" & LS).Resize(p, UBound(Tmp, 2)).Value = Tmp p = 0 Next ws End Sub

ا جازانا و اياكم جرب و قل تعديلك

حياك الله 🙂 من وين جابوا سالفة الدكتور هاي 🤔 ليكون انا صدق دكتور وانا ما ادري 🤭

وعليكم السلام تعتمد طريقتى على الاكواد داخل موديول عام والذى يتم استدعاؤها من خلال وضع الكود الاتى فى حدث عند تحميل نموذج Call Xicon والكود داخل الموديول هو مع مراعاة تغيير البيانات الاتية فى رأس الموديول اسم التطبيق AppName اسم الايقونة بدون الامتداد icoName وتم عمل الكود على ان الايقونة فى نفس مسار القاعدة فى حالة تغيير مكان الايقونة لابد من تغير المسار فى الروتين AppIcon() Const AppName = "Alia Yusr El Din" Const icoName = "4" Public Function AppIcon() AppIcon = CurrentProject.Path & "\" & icoName & ".ico" End Function Public Function AccessIcon() AccessIcon = (SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE") Debug.Print AccessIcon End Function Function AddAppProperty(strName As String, _ varType As Variant, varValue As Variant) As Integer Dim dbs As Object, prp As Variant Const conPropNotFoundError = 3270 Set dbs = CurrentDb On Error GoTo AddProp_Err dbs.Properties(strName) = varValue AddAppProperty = True AddProp_Bye: Exit Function AddProp_Err: If Err = conPropNotFoundError Then Set prp = dbs.CreateProperty(strName, varType, varValue) dbs.Properties.Append prp Resume Else AddAppProperty = False Resume AddProp_Bye End If End Function Function Xicon() On Error GoTo ErrHandler Dim dbs As Object Set dbs = CurrentDb() Dim intX As Integer Const DB_Text As Long = 10 ' AppTitle intX = AddAppProperty("AppTitle", DB_Text, AppName) ' AppIcon Dim Chk Dim MyIcon As String Set Chk = CreateObject("Scripting.FileSystemObject") If Chk.FileExists(AppIcon()) = False Then MyIcon = (SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE") Else MyIcon = AppIcon() End If intX = AddAppProperty("AppIcon", DB_Text, MyIcon) dbs.Properties("UseAppIconForFrmRpt") = 1 Application.RefreshTitleBar exitProc: Exit Function ErrHandler: If Err = 3270 Then Resume Next Else MsgBox Err & Err.Description Resume exitProc End If End Function testIcon.zip

So simple. Do it yourself Create a variable and name it for example counter Then inside the loop and before the line that populates the value "Total" increase the variable by one like that counter = counter + 1 And finally put the ampersand symbol after the word "Total" and the variable name which is counter. That's all

السلام عليكم ورحمة الله تعالى وبركاته تم تعديل المرفق وتغيير الاكواد حاولت جعل الية العمل اكثر سلاسة من التعقيدات التى كانت بالشرح والمرفق القديم المميزات - انشاء رمز Qr وحفظ صورته في المسار القاعدة - إمكانية قراءة البيانات من أي صورة تحتوى على QR CODE للبيانات التي تريدها ملاحظة هامة .. لابد من وجود Framework الاصدار 4 وأخيرا المرفق..... في انتظار آرائكم بعد التجربة Generate Or Read QR Code Image V.02.zip

نزولا عن رغبة الاحبة بتزويده ببرنامج محاسبة شركات شامل اضع بين ايديكم هذا العمل المتواضع User Name : admin Password : 1 أي رقم سري يواجهكم خلال استخدام البرنامج استعمل 12345 أي سؤال ان اجاهز Accounting Prog.rar

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

اتفضل يا استاذ @abouelhassan abouelhassan.accdb

جرب هذا الجمع بشرط.rar

تسلم ماتقصر الله يعطيك العافيه

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

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

اتفضل يا استاذ @at_aziz قمت بعمل الروتين الآتي ليقوم بإنشاء حقل لمسار الصورة الخاصة بالـ QR انظر الى الاستعلام qryData وهو الان مصدر بيانات كل من النموذج والتقرير تم انشاء المسار حسب الروتين من خلال الـ ID لأنني مسبقا جعلت صورة الـ Qr يتم انشاءها بناء على قيمة حقل الـ ID طبعا حضرتك تقدر تغير الى اى حقل غير الـ ID بس يكون يونيك طبعا بعد ذلك جعلت مصدر بيانات الصورة هو الحقل الجديد الذى تم انشاءه في الاستعلام Public Function QrImgPath(ByVal intNo As Integer) QrImgPath = CurrentProject.Path & "\Program Files\QR images\" & Dir(CurrentProject.Path & "\Program Files\QR images\" & intNo & ".png") End Function ---------------------- ويا استاذ @moamen salem تم التعديل فى المرفق كذلك حتى تحصل على النتيجة مؤمن سالم حسن عبداللطيف من خلال منشئ التعبير وليس من خلال الاكواد 386392877_GenerateOrReadQRCodeImageV.03.mdb

على المرفق الرئيسي لان حاليا ماعندي مثال اعمل عليه لكن راح انقل نفس الكود لمثال اخر شاكر لك ومقدر استاذي الكريم

فى انتظار ردكم استاذى الحبيب @at_aziz

اتفضل =[txtFirstName] & Chr(13) & Chr(10) & [txtFatherName] وانظر الى الرابط الاتى https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/miscellaneous-constants طيب هل تريد ان أقوم بعمل ذلك في المرفق الرئيسي ام تريد ان تأتى بمرفقكم ليتم التعديل عليه مباشرة

وعليكم السلام ورحمة الله وبركاته 🙂 اهلا وسهلا بك في المنتدى 🙂 للإستفادة القصوى من المنتدى ، رجاء قراءة قوانين المنتدى : اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة بالنسبة الى سؤالك: جرب هذا الكود (الغير مجرب) : 'ID = "رقم البطاقة" 'iDate = "تاريخ الانتساب" 'tbl = اسم الجدول dim rst as dao.recordset dim inc as long set rst=currentdb.openrecordset("Select ID, iDate From tbl Order By iDate") rst.movefirst inc= 450000 'Forms!frm123!initial_Number do until rst.eof inc = inc + 1 rst.edit rst!ID = inc rst.update rst.movenext loop rst.close: set rst=nothing msgbox "Done" . ولكن رجاء اعمل نسخة من جدولك قبل تجربة الكود 🙂 جعفر

هل هذا ما تريد اخي

اخى الكريم يمكنك الاستفادة من هذا الموضوع

جزاك الله وبارك الله فيك ابا جودي مثال جدا رائع ومهم اخي الكريم كيف يتم عرض QRCODE على تقرير ليتم طباعة بعد اظهاره على النموذج

اشكر حضرتك جدا جدا وجزاك الله الف غير وجعله في ميزان حسناتك معليش اطلت علي حضرتك كثير اكون ممنون لحضرتك لو عملت الفكرة في منشئ التعبير ولا اقصد فكرة QR اقص فكرة اني اجعل مصدر حقل غير منضم يظهر فيها الاسم علي سطرين

جرب الكود التالي Option Explicit Sub PRINT1() Dim DT, dt2 Dim RG Dim x DT = Sheets("ST").Range("c3"): dt2 = DT RG = Sheets("ST").Range("e3") For x = 1 To RG Sheets("P.R.T").Range("b3") = dt2 Sheets("P.R.T").PrintOut Copies:=x, Collate:=True, _ IgnorePrintAreas:=False dt2 = Format(DateAdd("m", 1, dt2), "yyyy-mm-dd") Next End Sub تجربه الطباعه.xlsm

Private Sub ComboBox1_Change() Const iCols As Integer = 11 Dim a(1 To 1000, 1 To iCols), b(), rng As Range, c As Range, i As Long, ii As Long With Sheets(1) Set rng = .Range("B3:M" & .Cells(Rows.Count, "B").End(xlUp).Row) rng.AutoFilter Field:=12, Criteria1:=ComboBox1.Value On Error Resume Next Set rng = .Range("B3").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible) On Error GoTo 0 End With If Not rng Is Nothing Then For Each c In rng i = i + 1 For ii = LBound(a, 2) To UBound(a, 2) a(i, ii) = c.Offset(, ii - 1).Value Next ii Next c b = Application.Transpose(a) i = Application.Min(UBound(a, 1), i) ReDim Preserve b(1 To iCols, 1 To i) b = Application.Transpose(b) ListBox1.List = b End If End Sub

السلام عليكم 🙂 لا يمكن تصفية مربع التحرير إلا من حقل واحد ، لذا ، سنستخدم حيلة في انه اذا القيمة غير موجودة في الحقل ، فنستخدم الكود التالي لجلب القيمة المطلوبة: Option Compare Database Option Explicit Private Sub idbf_NotInList(NewData As String, Response As Integer) Dim ctlList As Control, i As Integer ' Return Control object variable pointing to list box. Set ctlList = Me.idbf ' Enumerate through selected items. For i = 0 To ctlList.ListCount - 1 If ctlList.Column(2, i) = NewData Then ctlList.Value = CInt(ctlList.Column(0, i)) Me.fo.SetFocus GoTo Get_Out End If Next MsgBox "هذه القيمة غير موجودة في القائمة" Get_Out: Response = acDataErrContinue End Sub . جعفر Combo_value_from_another_column.zip

وعليكم السلام ورحمة الله وبركاته الملف الخاص بك ليس به مشاكل

على كل حال جرب المرفق ولى عودة ان كان هناك جدوى 12.accdb

اخى الكريم عملته عن طريق اكسس 2003

تشكراتي لك باش مهندس محمد .. 🌹

السلام عليكم ورحمة الله تعالى وبركاته اساتذتى الكرام صباح الخيرات حالوت التعديل على قاعدة البيانات المرفقة حتى تعمل على كل من النواتين 32 , 64 ولكن حدثت مشكلة فى السطر الاتى lpPrevWndProc = apiSetWindowLong(hwnd, GWL_WNDPROC, AddressOf fWndProcTray) وبالأخص فى تلك الجزئية من السطر AddressOf fWndProcTray هل هناك حل لذلك القاعدة المرفقة هى القاعدة الأصلية تحسبا ان كان هناك خطأ منى عند محاولة تحويل الاكواد هل اجد من يتصدق على بتحويل القاعدة وحل المشكلة جزاكم الله خيرا لم اقوم بوضع مشاركتى الا بعد عناء طويل مرير من البحث Utilities Hide Ico Minimze To SysTray V.02.zip

لحل المشكلة احفظ الملف على word97-2003، وبعدها لن تظهر لك رسالة حفظ باسم. دمتم بخير

السلام عليكم إخواني الكرام ... أشعر أن المنتدى كله مركز على الأسئلة والطلبات أكثر من الموضوعات التعليمية .. فإليكم درس خفيف ظريف ولن يستغرق منك في دراسته أكثر من 4 دقائق .. ************** نتحدث بشكل سريع عن استخدام دالة VLOOKUP للبحث عن جزء من النص داخل نطاق .. إليكم الملف المرفق به الشرح ، وأي استسفار أو سؤال لا تتردد واسأل ، لا تخجل من السؤال مهما بدا تافهاً لأن السؤال طريق ..طريق (وكله مطبات) بس هو طريق المعرفة .. VLOOKUP Text Inside A String.rar

جرب أخي الفاضل جرب هذا الملف Test This.rar

أخي الحبيب إليك الملف التالي فيه معادلة لحساب التقديرات بكل سهولة بمعادلة واحدة بدلا من التعقيدات Level Formula.rar

بعد إذن أستاذي ( عباد ) وهذه المعادلة الأكثر من رائعة حلين أخريين بجانب هذه المعادلة الرائعة لعلة يفيد Vluk_2.rar

السلام عليكم ورحمة الله أخي الكريم، أرفق لك الملف من جديد مع تعديل المعادلات لضبط القائمة وقاعدة البيانات... أخوك بن علية عقد عمل2.rar

للاسف تظهر كما هى فى ويندوز 8 الى ما فوق ذلك