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

جزاكم الله خيرا

وعليكم السلام ورحمه الله وبركاته اتفضل اخى واستاذى محمد @أبو عبدالله الحلوانى Dim QryStr As String 'On Error Resume Next QryStr = "INSERT INTO InvoiceDetailTbl ( IDs, OldInvs, jyarID, Movtyp, StorID, DmanSt, VoicDtID, Quentity, price ) " & _ "SELECT MovmentTbl.ID, MovmentTbl.OldInvs, MovmentTbl.jyarID, 2 AS MovTyp, MovmentTbl.StorID, MovmentTbl.AoryntID, " & _ "'" & InvNo & "' AS InvExp, MovmentTbl.QntyOut, MovmentTbl.AmtJyarOut FROM MovmentTbl " & _ "WHERE (((MovmentTbl.BlajID)='" & bljNo & "'));" بالتوفيق

كيفية جعل صفحة عرض مناسبة مع جميع شاشات الحواسيب ضع هاذا التعريف فوق الفروم لود Dim ProportionsArray() As CtrlProportions وفي الفروم لود ضع هاذا الكود Informload() End Sub Private Structure CtrlProportions Dim HeightProportions As Single Dim WidthProportions As Single Dim TopProportions As Single Dim LeftProportions As Single End Structure Private Sub Form1_Resize(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Resize Resizeform() End Sub Sub Informload() On Error Resume Next Application.DoEvents() ReDim ProportionsArray(0 To Controls.Count - 1) For I As Integer = 0 To Controls.Count - 1 With ProportionsArray(I) .HeightProportions = Controls(I).Height / Height .WidthProportions = Controls(I).Width / Width .TopProportions = Controls(I).Top / Height .LeftProportions = Controls(I).Left / Width End With Next End Sub Public Sub Resizeform() On Error Resume Next For I As Integer = 0 To Controls.Count - 1 Controls(I).Left = ProportionsArray(I).LeftProportions * Me.Width Controls(I).Top = ProportionsArray(I).TopProportions * Me.Height Controls(I).Width = ProportionsArray(I).WidthProportions * Me.Width Controls(I).Height = ProportionsArray(I).HeightProportions * Me.Height Next

السلام عليكم ورحمة الله تعالى وبركاته على كل مصممى ومطورى قواعد البيانات ببساطة عند محاولة تشفير قاعدة البيانات الى accDE لابد من إنشاؤها مره باستخدام office (Access) x64 و إنشاؤها مره أخرى باستخدام office (Access) x32 حتى لا تحدث مشكلة عند العملاء بسبب إختلاف أنوية الأوفيس للاسف الشديد . للعلم الموضوع مختص فقط بتشفير القاعدة بالامتداد Accde فقط اى أنه لا علاقة للموضوع بالامتداد Accdb ولا علاقة للموضوع باستخدام دوال API حتى لو تم الاخذ فى الاعتبار عند كتابة الكود مراعاة عمل الكود عند استخدام دوال API على كلتا النواتان 64x , 32 x هذه لقطة من مقال المصدر : >>--> مايكروسوفت لذلك فإن accDE الخاص بـ x32 accDE و x64 خاصان جدًا بحجم النواه والبنية التي تم تجميعهما بها ويجب أن تعمل الأجهزة المستهدفة بنفس حجم النواة لاستعمال accDE الذي تم إنشاؤه باستخدامه ولا توجد استثناءات لهذه القاعدة

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

السلام عليكم ورحمه الله وبركاته اخى ومعلمى وشيخنا الجليل @ابوخليل بالنسبه لهذا الموضوع وما مررت به بانه فى حاله لم يتم تحويل البرنامج الى accde فان الامور كلها تمام ولكن فى حاله التحويل يلزم التحويل على نفس بيئه العمل لضمان التحويل والعمل بشكل سليم وكما ورد بالموضوع التالى لاخى العزيز @ابو جودي والله اعلى واعلم

المنتدى مليء بمثل هذه المواضيع اكتب في البحث كلمة : تحزيم وهذا واحد منها ملحوظة : تم دمج الموضوعين

In worksheet module, paste the following code Private Sub Worksheet_Change(ByVal Target As Range) Dim x, m As Long If Target.Address = "$E$2" Then If Target.Value = Empty Then Exit Sub x = Application.Match(Val(Target.Value), Columns(1), 0) If Not IsError(x) Then With Sheets("Copied") m = .Cells(Rows.Count, 1).End(xlUp).Row + 1 Rows(x).Copy .Cells(m, 1) End With MsgBox "Row " & x & " Copied Successfully", 64 Else MsgBox "No Found", vbExclamation: Exit Sub End If End If End Sub

السلام عليكم أرفق لكم قاعدة بيانات فيها جدول فيه ايات القران الكريم كاملا عمود فيه القران بالتشكيل وعمود بدون تشكيل وقد بدأت بعمود يحوي على الرسم العثماني لكن لم استطع اكماله بعد وستجد فيه ايضا رقم الجزء ورقم السورة ورقم الاية والحزب تحياتي للجميع ayat.zip

برنامج للقرآن الكريم بالأكسس https://drive.google.com/file/d/1oo09ouXvc-3hKYEz3d71avbjckzFfvAG/view

Try Sub Test() Debug.Print SubtractDigits("18538964") End Sub Function SubtractDigits(ByVal s As String) As Integer Dim i As Long, d As Long, r As Long For i = 1 To Len(s) d = CInt(Mid(s, i, 1)) - r r = Abs(d) Next i SubtractDigits = r End Function

استاذ عمر وجدت لك هذا الملف من موقع اجنبي..لعله يفيدك (الاكواد فيه جمالية) بالمناسبة استاذ عمر الان فتحت ملفك..مالذي تقصده بهذا التعبير =IIf([txtTodyDate]+2 Between [txtStart] And [txtEND],"1","0") Gantt_DB_PeterHibbs.zip

فحص المفتاح وتشغيله عندما يكون لا يعمل: Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer Sub NumLockCheck() If GetKeyState(&H90) = 0 Then mySendKeys "{NUMLOCK}" End Sub

السلام عليكم ممكن توضيح !!!

نعم

السلام عليكم ورحمة الله وبركاته هي الطريقة سهلة ان شاء الله البيانات نفترض انها في ورقة واحد وتبغى ورقة اثنين تاخذ البيانات من ورقة واحدصحيح طيب اذا كان كذا حدد الخلية في ورقة 2 واكتب يساوي وبعدين روح للورقة 1 واختر الخلية الي تبيها تنتقل لورقة 2 وبعدين انتر مرفق مثال مثال.xlsm

بارك الله بك وبالاستاذه الفاضله والمميزه زهرةة

تفضل أخي طلبك . VACATIONS-2.rar

تفضل أخي سويت لك استعلام رصيد الاجازات الكلية لكل موظف من تاريخ التعيين (VacationsTotal) بالمرفق . VACATIONS-1.rar

حيا الله استاذ عمر.. في تقديري وحسب عملي ..افضل برنامج لادارة المشاريع هو ال primavera وهو برنامج راقي جدا ينفذ الكثير من المهام ومن البرامج السهلة في هذا الشأن من مايكروسوفت هو برنامج Microsoft Project..وهناك الكثير طبعا لكني اشتغلت فقط عليهم

شكرا لكم جميعا وبارك الله فيكم

Before this line shTarget.Range(columnMappings(i)).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr you can add this line shTarget.Range(columnMappings(i)).Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents

ربما Sub test2() Dim a Dim LR& a = Sheets("sheet1").Cells(13, 2).CurrentRegion With Sheets("sheet2").Cells(10, 4) LR = Cells(Rows.Count, 4).End(xlUp).Row .Resize(LR, 3).ClearContents .Offset(, 8).Resize(LR).ClearContents .Offset(, 10).Resize(LR).ClearContents .Offset(, 12).Resize(LR).ClearContents .Resize(UBound(a) - 1, 3) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), Array(2, 3, 4)) .Offset(, 8).Resize(UBound(a) - 1) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), 7) .Offset(, 10).Resize(UBound(a) - 1) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), 10) .Offset(, 12).Resize(UBound(a) - 1) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), 5) End With End Sub

Try Sub Test() Dim colSource, colTarget, ws As Worksheet, sh As Worksheet, lr As Long Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) lr = ws.Cells(Rows.Count, "C").End(xlUp).Row colSource = Array("C:E", "H", "K", "F") colTarget = Array("D10", "L10", "N10", "P10") PopulateArray ws, sh, 14, lr, colSource, colTarget End Sub Public Sub PopulateArray(ByVal wsSource As Worksheet, ByVal shTarget As Worksheet, ByVal sRow As Long, ByVal lr As Long, ByVal rangesToPopulate, ByVal columnMappings) Dim arr, rangeColumns, rng As Range, i As Long Application.ScreenUpdating = False For i = LBound(rangesToPopulate) To UBound(rangesToPopulate) If InStr(1, rangesToPopulate(i), ":") > 0 Then rangeColumns = Split(rangesToPopulate(i), ":") Set rng = wsSource.Range(rangeColumns(0) & sRow & ":" & rangeColumns(1) & lr) Else Set rng = wsSource.Range(rangesToPopulate(i) & sRow).Resize(lr - sRow + 1) End If arr = rng.Value shTarget.Range(columnMappings(i)).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr Next i Application.ScreenUpdating = True End Sub

اذا اردت تشفير قاعدة البيانات بتحويلها من Accdb الى Accde لابد من عمل قاعدتان امامية واخرى خلفية طبعا قاعدة البيانات الخلفية والخاصة بالجداول لابد ان تكون غير مشفرة اى Accdb اما الامامية ان اردت تشفيرها الى Accde لابد من عمل ذلك مرتين 1- على جهاز يحتوى على اوفيس 32 بيت 2- على جهاز يحتوى على اوفيس 64 بيت وتعطى للعميل مع قاعدة الجداول الخلفية القاعدتان الاماميتان والمشفرتان الـقاعـدة الامامية ذات النواة 32x المشفرة ذات الامتداد Accde والقاعدة الامامية ذات النواة 64x المشفرة ذات الامتداد Accde حتى يستخدم القاعدة الامامية التى تتوافق مع نواة الاوفيس لديه او اذا قام العميل فى احد الايام بتغيير الاوفيس بإصدار آخر ونواة مختلفة يعمل بالقاعدة الاخرى او اذا كان العميل يملك اكثر من جهاز وقد تختلف انوية اصدارات الاوفيس من جهاز لاخر

وعليكم السلام اذا كان اسم الحقل الذي تريد نسخ المعلومة التي فيه Text0 ، فيصبح الكود: Me.Text0.SetFocus DoCmd.RunCommand acCmdCopy والان تستطيع ان تلصق هذه القيمة في اي برنامج جعفر

جرب هذا الملف قائمة منسدلة salim.rar

أخي الكريم حليم بسرعة عشان وقت صلاة الجمعة روح للتبويب Formulas ثم الـ Name Manager ثم انقر لكمة New واكتب اسم القائمة المطاطية اسم List مثلاً .. وضع المعادلة التالية =OFFSET(Feuil1!$C$8,0,0,COUNTA(Feuil1!$C:$C)-1,1) بعد كدا روح لورقة العمل المسماة Feuil2 وحدد الخلية C6 وروح للتبويب Data ثم Data Validation واختار List من القائمة وبعدين اكتب كلمة =List في المعادلة الخاصة بالقائمة .. بس خلاص وتقبل تحياتي