نجوم المشاركات
Popular Content
Showing content with the highest reputation on 02/03/21 in مشاركات
-
تم عمل المطلوب بطريقة بدائية جرب المرفق ووافني بملاحظاتك حساب المدير : اليوزر = a الباسوورد = 1 حساب المستخدم : اليوزر = b الباسوورد = 2 ملاحظة في محلها .. ولا اخفيك اني قرأت ملاحظتك بعد ان ادرجت الكود ، والآن الكود معطل اذا اردت يا اباحسان تفعيل اخفاء الاطارات افتح نموذج frmlogin على التصميم واذهب الى حدث تحميل النموذج تجد الدالة المسؤولة HideAccess' معطلة ، كل ما عليك فعله ان اردتها تعمل هو ان تزيل علامة التنصيص الصغيرة الموجودة يسار الدالة . ومؤكد ستفاجأ بعد تفعيلها انه لا يمكنك الدخول الى طار قاعدة البيانات ولن ترى الكائنات .. ما الحل ؟ الحل هو ان تضغط على زر الشيفت بيدك اليسرى وتستمر ضاغطا بينما يدك اليمنى تقوم بتشغيل قاعدة البيانات .. ستلاحظ ان قاعدة البيانات فتحت على التصميم هنا اذهب الى الدالة المذكورة وعطلها ان احببت Data3.rar3 points
-
اخبرني احد الأخوة أن المرفق لا يعمل ويبدو وكانه فيرس سأقوم بتحميل المرفق بصيغة accdb أشكر أخوتي أ/ @kanory و أ/ @abouelhassan علي مروهم الكريم وكلماتهم الطيبات ولا انسا تقديم الشكر للأستاذ أحمد عبدالمنعم صاحب هذا الفيديو فقد كان من المصادر الهامة أيضا هذا MenuAndShortCutMenu.accdb2 points
-
2 points
-
وعليكم السلام 🙂 ولو اننا بحاجة الى معرفة طريقة ارسال البيانات الى هذه الدالة ، ولكن جرب : Function m_ar(a As integer) As String If a < 20 Then m_ar = "عربي" Else m_ar = "" End If End Function جعفر2 points
-
2 points
-
لم ارد عليك ، لأني بدأت أقرأ زيادة من ذلك لوقت (وطلعت من البيت حبتين ، وتغديث ، واخذت غفوة ، وواصلت القراءة 🙂 ) ، اعطيك رابطين من المواقع الاجنبية: الاول مجمع جميع الاقتراحات : Access - Bug - Database is in an Unrecognized Format | DEVelopers HUT (devhut.net) والثاني الاخذ والعطاء فيه لايزال مستمر من حوالي سنتين حول هذه النقطة وما حولها : Access Database is getting corrupt again and again - Microsoft Community الله يعينك ، ورجاء تخبرنا وين توصل 🙂 جعفر2 points
-
هذا هو المرفق أرجو أن ينفع الله به أحدا من المسلمين المرفق يحتاج اضافة مرجع كما بالصورة المراجع والمصادر: 1- من شركة مايكروسوفت 2- لمزيد من الشرح والتوضيح من معلمنا أ/ جعفر MenuAndShortCutMenu.rar InsertReference.rar2 points
-
السلام عليكم يعطيكم العافية بحثت عن ارسال sms من الاكسس لكن حصلت اغلب المواضيع قديمة وبعض مقدمين الخدمة تقيمهم سيء ممكن الي جرب يتكلم لنا عن تجربته من حيث الاكواد و مواقع مقدمين خدمات اسعارهم مناسبة و ارسال الرسائل بشكل سريع1 point
-
1 point
-
1 point
-
بسم الله ماشاء الله ربنا ييارك فيك وفى اولادك الى يوم الدين ويرزقك برهم فى الدنيا والاخره ويقر عينك بهم هو المطلوب بالفعل بعد طول انتظار ولكن اثمرت النتائج بالخير بارك الله فيك ياغالى1 point
-
1 point
-
ايضا جرب طريقة ناجحة في الغالب خاصة اذا كان الخلل في جداول النظام ، وهي نقل جداولك الى قاعدة جديدة1 point
-
هل من الممكن أن يتم عمل تلك القائمة اتوماتيك وليس بزر أمر (تم عمل ذلك اذا لم تظهر ثائمة الاسماء غادر الصفحة ثم عد اليها) 1- عودة الصف رقم 6 للعمل داخل الصفحة(DATA) لضرورة انشاء جدول للفلتر 2-الضفحة تدرج مباشر ة بعد الشيت DATA 3- هذا الماكرو يدرج صفحة باسم كل عميل مع بياناته بشكل مستقل ( الزر Sheet For Every one) 4-اذا زاد عدد العملاء الكود يتصرف بهذا الأمر Option Explicit Sub ADD_Sheet() Dim D As Worksheet Dim m%, i%, Rod, RoH% Dim Ft_rg As Range, Crit$ Dim Ar_sh(), itm Set D = Sheets("DATA") Set Ft_rg = D.Range("a5").CurrentRegion Rod = D.Cells(Rows.Count, 1).End(3).Row RoH = D.Cells(Rows.Count, "H").End(3).Row With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With If Rod < 6 Or D.Cells(6, "H") = vbNullString Then GoTo Bay_Bay_Ya_Helween End If For i = RoH To 6 Step -1 If Not Application.Evaluate("ISREF('" & _ D.Range("H" & i) & "'!A1)") Then Sheets.Add(, after:=Sheets("DATA")).Name = _ D.Range("H" & i) End If Next D.AutoFilterMode = 0 For i = 1 To Sheets.Count If Sheets(i).Name = "print" Or Sheets(i).Name = "DATA" Then Else ReDim Preserve Ar_sh(m) Ar_sh(m) = Sheets(i).Name m = m + 1 End If Next For Each itm In Ar_sh Sheets(itm).Range("A6").CurrentRegion.Clear Ft_rg.AutoFilter 1, itm Ft_rg.SpecialCells(12).Copy Sheets(itm).Range("A6").PasteSpecial (8) Sheets(itm).Range("A6").PasteSpecial Sheets(itm).Range("H6") = "Account Of" & Space(3) & itm _ Next itm D.Select D.AutoFilterMode = 0 Bay_Bay_Ya_Helween: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub Issa_Macro_New.xlsm1 point
-
حقيقة لا أذكر كيف تم حل المشكلة لدي عند وقوعي بهذه المشكلة من قبل ولعله بعد تحديث نسخة الوندوز الي ويندوز 10 أو تحديث نسخة الأوفس الي أوفيس 16 ربما ولكن لا أذكر تحديدا ما حدث بالضبط ولكن لعل هذه المشكلة تنذرك بكبر حجم قاعدة البيانات لديك وأنها لم تعد تستطيع الصمود لاكمال المسيرة الي النهاية أو هنالك مشكلة أكبر قد تحدث بعد لذي جئت ناصحا بـ: 1- أخذ نسخة احتياطية بشكل يومي الي حين الوصول الي حل ان شاء الله 2- حاول تكبير قاعدة البيانات (أقصد التعامل مع الـ SQL server) حقيقة ستجد به متسع من الأمان وسعة التخزين وبعدا عن مشكلات الأكسس كهذه التي بين يديك. أعرف أن الاقتراح الثاني ليس سهلا للغاية ولكنه لا يصعب علي أبي جودي تمنياتي بالتوفيق وحل المشكلة بأجل قريب ان شاء الله.1 point
-
1 point
-
السلام عليكم اذكر ان لم تخني الذاكرة اني مررت بمثل او شبيه لهذه المشكلة واعتقد اني وضعت يدي على الخلل حينها ، وهو خلل خفي لا يرى بالعين المجردة جرب حاول تعيد تسمية .. اقصد تعيد كتابة التسمية لكل من : قاعدة البيانات الخلفية المجلد الذي يحتوي عليها الرابط الموصل اليها خاصة اسم القاعدة في الرابط _____ وما دام هي تجربة في تجربة .. ان لم تفلح في التجربة الأولى حاول تعيد التسميات بأسماء مختلفة1 point
-
قمت بالتعديل على المثال الذى ارفقه الاخ الفاضل ابوحوده ان شاء الله يكون ما تريد 11(1).accdb1 point
-
1 point
-
جرب هذا لعله يوافق مرادك اذن صرف ادوات نظافة.rar1 point
-
وعليكم السلام ورحمة الله وبركاته الحفظ في D يمكنك تغيره في الكود backup.xlsm1 point
-
1 point
-
اما الكود فيمكنك اختصاره كالتالي: If DCount("*", "qry_tbl2", "HNO =" & Me.tn) = 0 Then MsgBox "الرقم غير موجود" Else Me.Recordset.FindFirst "hno=" & Me.tn End If Me.tn.SetFocus Me.tn = "" ومع اني لا اعرف كيف وصل المؤشر هناك ، ولكن ، بما ان في هذا النموذج هو للبحث فقط ، فيمكن قفل هذا الحقل من التعديل ، هكذا : . جعفر1 point
-
1 point
-
1 point
-
اخى الكريم ابا جودى اشكرك جزيل الشكر على المساعدة الكود المرفق تم إضافة اسم المجلد الى اسم الصورة تم الاضافة الى الكود ShortPath = DBPath & "Scan" & "\" & FDName الف شكر حقا منتدى رائع1 point
-
تم التعديل كما تريد 1-تحنار الفضل من الخلية Bx6 ثم تضغط على الزر Fasl 2- الماكرو القديم ما زال يعمل (للفصلين معاً ) الزر ALL الماكرو الجديد Option Explicit Sub checK_up_By_Fasl() Dim F As Worksheet Dim Arr(), Itm, My_sum Dim m%, K%, i%, Ro%, y% Dim arr_madda() Const a = 4 Const b = 1 Dim Nb% Dim Res(), XX%, MY_text$ Dim Txt$: Txt = "المجمــــــوع الكلـــــــي" Set F = Sheets("F1") Ro = F.Cells(Rows.Count, 3).End(3).Row If Ro < 12 Then Exit Sub F.Cells(12, "H").Resize(Ro - 11, 49).Interior.ColorIndex = xlNone F.Cells(12, "Ca").Resize(Ro - 11, 49).ClearContents F.Cells(12, "Bx").Resize(Ro - 11).ClearContents Select Case F.Range("Bx6") Case "الأول": Nb = a Case "الثاني": Nb = b End Select For K = 8 To 55 If F.Cells(7, K) = Txt Then ReDim Preserve Arr(m): Arr(m) = K - Nb: m = m + 1 End If Next m = 0 For K = 8 To 50 If F.Cells(6, K) <> "" Then ReDim Preserve arr_madda(m) arr_madda(m) = F.Cells(6, K) & " / " & F.Range("Bx6") m = m + 1 End If Next For i = 12 To Ro y = 0 For Each Itm In Arr My_sum = My_sum + F.Cells(i, Itm) If F.Cells(i, Itm) < F.Cells(10, Itm) / 2 Then F.Cells(i, Itm).Interior.ColorIndex = 6 ReDim Preserve Res(y) Select Case Itm Case Is <= 13: Res(y) = arr_madda(0) Case Is <= 20: Res(y) = arr_madda(1) Case Is <= 27: Res(y) = arr_madda(2) Case Is <= 34: Res(y) = arr_madda(3) Case Is <= 41: Res(y) = arr_madda(4) Case Is <= 48: Res(y) = arr_madda(5) Case Is <= 55: Res(y) = arr_madda(6) End Select y = y + 1 End If Next Itm If y > 1 Then F.Cells(i, "Ca").Resize(, y) = Res Else F.Cells(i, "Bx") = My_sum End If Erase Res: y = 0: My_sum = 0 Next i End Sub الملف من جديد Khiri_ali_New.xlsm1 point
-
وعليكم السلام 🙂 حتى لا يحدث لك هذا مرة ثانية: 1. تأكد بأن برنامج الاكسس فيه آخر التحديثات ، 2. هذا قد يكون بسبب بعض تحديثات مايكروسوفت للوندوز ، من موقع مايكروسوفت: Access reports that databases are in an 'inconsistent state' - Access (microsoft.com) - يكفي عمل هذا العمل على السيرفر (او الكمبيوتر الذي عليه نسخة الجداول) ، ولا يضر ان تعمله على كمبيوتر الواجهة وكمبيوتر الجداول : - افتح برنامج CMD كمسؤول ، Windows Start and then type Command. Right-click on Command Prompt and choose Run as administrator - ثم اكتب هذه الاسطر الثلاث (انسخ اول سطر من هنا ، والصقه هناك ، واضغط على زر Enter لتنفيذ الامر ، ثم الصق الثاني ونفذ الامر ، ثم الثالث ونفذ الامر) : REG ADD HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\lanmanserver\parameters /v DisableLeasing /t REG_DWORD /d 1 /f NET STOP SERVER NET START SERVER . والآن ، اعمل ضغط واصلاح لقاعدة البيانات ، وجربها في المحيط الجديد 🙂 جعفر1 point
-
فى الكود تبعك ابحث عن السطر التالى ShortPath = DBPath & FDName وقم بتغييره الى هذا السطر ShortPath = DBPath & "اسم المجلد" & FDName مع استبدال اسم المجلد طبعا حسب الاسم الذى تريدعلى ان يكوم نفس اسم المجلد بنفس مسار قاعدة البيانات موجود1 point
-
بشركم الله تعالى بكل الخيــــــــر جزاكم الله خيـــــرا1 point
-
وعليكم السلام - يمكنك ذلك بهذه المعادلة =IF(RIGHT($A2,2)=C$1,TRIM(MID(SUBSTITUTE(C$1&$A2,C$1,REPT(" ",50)),COLUMN(A1)*50,50)),"") Book1.xlsx1 point
-
1 point
-
فكرة الكود ... خلال نموذج الدخول اذا كان اليوزر والباس صحيح يحدث هذا الحقل الى رقم واحد وعند الدخول من جهاز اخر يقوم بالتاكد من هذا الرقم في حال وجودة يعطي رسالة هناك مستخدم بنفس الاسم على جهاز اخر واذا كان هذا الحقل فارغ يفتح البرنامج طبيعي وطبيعي عند تسجيل خروج يمسح هذا الرقم لاعطائك فرصة للدخول مرة اخرى من اي جهاز اخر ...1 point
-
جرب هذا الماكرو Option Explicit Sub checK_up() Dim F As Worksheet Dim Arr(), Itm, My_sum Dim m%, K%, i%, Ro%, y% Dim arr_madda() Dim Res(), XX%, MY_text$ Dim Txt$: Txt = "المجمــــــــــوع" Set F = Sheets("F1") Ro = F.Cells(Rows.Count, 3).End(3).Row If Ro < 12 Then Exit Sub F.Cells(12, "H").Resize(Ro - 11, 49).Interior.ColorIndex = xlNone F.Cells(12, "Ca").Resize(Ro - 11, 49).ClearContents F.Cells(12, "Bx").Resize(Ro - 11).ClearContents For K = 8 To 55: If F.Cells(9, K) = Txt Then ReDim Preserve Arr(m): Arr(m) = K: m = m + 1 End If Next m = 0 For K = 8 To 50 If F.Cells(6, K) <> "" Then ReDim Preserve arr_madda(m): arr_madda(m) = F.Cells(6, K) m = m + 1 End If Next For i = 12 To Ro y = 0 For Each Itm In Arr My_sum = My_sum + F.Cells(i, Itm) If F.Cells(i, Itm) < F.Cells(10, Itm) / 2 Then F.Cells(i, Itm).Interior.ColorIndex = 6 ReDim Preserve Res(y) Select Case Itm Case Is <= 13: Res(y) = arr_madda(0) Case Is <= 20: Res(y) = arr_madda(1) Case Is <= 27: Res(y) = arr_madda(2) Case Is <= 34: Res(y) = arr_madda(3) Case Is <= 41: Res(y) = arr_madda(4) Case Is <= 48: Res(y) = arr_madda(5) Case Is <= 55: Res(y) = arr_madda(6) End Select y = y + 1 End If Next Itm If y > 1 Then F.Cells(i, "Ca").Resize(, y) = Res Else F.Cells(i, "Bx") = My_sum End If Erase Res: y = 0: My_sum = 0 Next i End Sub الملف مرفق Khiri_ali.xlsm1 point
-
1 point
-
هناك افكار عديدة لعمل ذلك منها هذه الصوره جرب تشغيل المرفق باي يوزر ..... ثم اعد تشغيل النموذج الرئيسي مرة اخرى ولا حظ جرب الخروج من النموذج عن طريق الضغط على Exit ثم اعد تشغيل النموذج الرئسي مرة اخرى ولاحظ Test_kan.accdb1 point
-
استكمالا لردي السابق كما تعلم استاذنا @jjafferr وبدون الدخول في التفاصيل ان هذه الطريقة تحتاج الى عدة خطوات والخطا قد يؤدى الى تلف قاعدة البيانات او حذف كافة الاكواد لذا لا افضل هذه الطريقة واستخدم طرق اخرى منها الطريقة الثانية عن طريق عمل Patch نفتح بواسطته الملف المحمي ويقوم بكامل العملية هذه الطريقة هي الاسهل والاكثر امان وبعد انتهاء العمل يمكن الاحتفاظ بالباتش لاستخدامه مع اي قاعدة بيانات اخرى هنا لن نستخدم احرف بشكل مباشر وانما التمثيل الست عشري الطريقة الثالثة بدون استخدام برامج خارجية عن طريق قاعدة بيانات اخرى نختار القاعدة المطلوب كسرها وتنفيذ عملية الكسر عن طريق كود بسيط انا افضل الطريقة الثانية واستخدمها عند الحاجة طبعا الموضوع ليس بتلك الاهميه ولكن من باب الشيء بالشيء يذكر1 point
-
1 point
-
اذا كان هناك فراغات يمكن ان نتجاوزها بهذا الكود و لا لزوم لما لا يلزم من وضع 2 Arrays واحد لكل شيت Option Explicit Sub All_in_One() Dim First As Worksheet Dim arr(1), Sh, i%, x% Dim dic As Object Set First = Sheets("Sheet1") Set dic = CreateObject("Scripting.Dictionary") arr(0) = "Sheet2": arr(1) = "Sheet3" First.Range("B1").CurrentRegion.ClearContents For Each Sh In arr x = Sheets(Sh).Cells(Rows.Count, 2).End(3).Row i = 2 Do Until i > x If Sheets(Sh).Range("B" & i) <> "" Then dic(Sheets(Sh).Range("B" & i).Value) = vbNullString End If i = i + 1 Loop Next Sh If dic.Count Then First.Range("B2") = "Names" First.Range("B3").Resize(dic.Count) = _ Application.Transpose(dic.keys) First.Range("A3").Resize(dic.Count) = _ Evaluate("Row(1:" & dic.Count & ")") End If Set dic = Nothing: Set First = Nothing Erase arr End Sub1 point
-
جرب هذه المحاولة بمجرد الكتابة في الخلية c2 سيتم جلب البيانات غير اسماء الشيتات اجعل ورقة البيانات"data" وورقة التقرير report وضع الكود في ورقة التقرير Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("c2")) Is Nothing Then Sheets("data").Cells.AutoFilter Field:=1, Criteria1:=Target.Value Sheets("data").AutoFilter.Range.Columns("A:q").Offset(1).Copy Sheets("report").Range("A10") End If Sheets("data").AutoFilterMode = False End Sub1 point
-
1 point
-
في المثال المرفق تجد الطريقة و عدة طرق طرق لنقل البيانات و شرح مفصل لكل العمليات SyncDataExample_v5.3.zip1 point
-
جرب هذه المعادلة (Crtl+Shift+Enter) وليس Enter وجدها =VLOOKUP(SUM(IFERROR(IF(ISNUMBER(FIND({"Can limon";"Rosie"},A3)),ROW($A$1:$A$12),""),"")),{0,0;1,100;2,70},2,0) File included vlk_Find.xlsx1 point
-
عليك استخدام هذه المعادلة طبقاً لطلبك =IF(A3="","",IF($A3="Can limon",0%,IF($A3="Rosie",100%,70%))) New Microsoft Excel Worksheet1.xlsx1 point
-
اتا ارى من الافضل ادراج الاسماء في فائمة منسدلة مطاطة (لا الأرقام) مطاطة اي انها تستجيب لاي تغيير في قائمة الاسماء(نعديل/ اضافة/حذف....) اذا لم تظهر لك القائمة المتسدلة غادر الصفحة (Cerificats) ثم عد اليها مجدداً الملف مرفق Notes.xlsm1 point
-
تفضل-يمكنك استخدام هذه المعادلة =IFERROR(IF(COUNTIF($B$4:B4,B4)=1,U4&VLOOKUP($B4,$U$1:$V$2,2,0),U4&VLOOKUP($B4,$U$1:$V$2,2,0)+(COUNTIF($B$4:B4,B4)-1)),"") ترقيم وتسلسل.xlsx1 point
-
هلا اخوي. بنسبه لي مزودي الخدمه في الكثير. منهم وي ارخصهم بنسبه لي مملكة الرسائل وأيضا سماء sms وايضا موبايلي لرسائل الجوال والكثير فقط. اكتب في البحث ارسل رسل من خلال api. وستجد الكثير وكل موقع يعطك الاكود الخاصه بربط1 point
-
السلام عليكم .. على سبيل التخمين لأنني لا أدري ما المطلوب إلى الآن .. جرب الكود التالي Sub text() Dim ws As Worksheet Dim a As Variant Dim c As Range Dim i As Long Dim r As Long Dim ss As Long Set ws = ActiveSheet a = ws.Range("A2:B" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Value For i = LBound(a, 1) To UBound(a, 1) If a(i, 2) <> "" Then r = r + 1: a(i, 1) = r Else r = 0: a(i, 1) = "" End If Next i ws.Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a TextBox2.Visible = True TextBox5.Visible = False If Me.TextBox6.Value <> "" Then ss = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 Me.TextBox2.Value = ss Else Me.TextBox2.Value = "" End If End Sub1 point
-
السلام عليكم ورحمة الله وبركاته بارك الله فيك أخي معتصم واسمح لي بإضافة الدالة (GETPIVOTDATA) تختص بالتعامل مع الجداول المحورية و تمتاز الدالة بإمكانية البحث في الجداول المحورية وفقا للكثير من العناصر في تسمية الصفوف وفي تسمية الأعمدة إلا أن الدالة تعيد النتيجة من حقل القيم فقط . أما استخدام دوال البحث الأخرى فذلك ممكن وللتغلب على مشكلة عدم ثبات طول نطاق الجداول المحورية نستخدم - نطاق ذو مدى متغير- بواسطة معادلات , ومن افضل المعادلات المستخدمة لتحديد طول المدى هي الدالة (GETPIVOTDATA) نظرا لأنها لا تسبب بطئ للملف. والدالة (GETPIVOTDATA)في هذه الحالة تحتاج إلى حقل أجمالي عدد البيانات. وللعلم الدالة (GETPIVOTDATA) اكثر سرعة في إعادة النتائج مقارنة بدوال البحث الأخرى ويمكن ملاحظة ذلك عند البحث في بيانات كبيرة الرابط التالي يحتوي على مثال لاستخدام الدالة GETPIVOTDATA http://www.officena.net/ib/index.php?showtopic=38907 في امأن الله1 point
-
السلام عليكم ورحمة الله أخي الكريم تعقيبا لما ذكره أخي الكريم أبو البراء في رده الأول فالأمر كماقال، إن في ملفك خلايا من الأعمدة الأخيرة في الورقة غير فارغة إما مملوءة بمعطيات أم أنك قمت بتلوين كامل لبعض (سطر أو أكثر) الأسطر وبالتالي يجب القيام بما يلي: 1- مسح محتويات هذه الخلايا إذا لم تكن بحاجة إليها (ولو من فراغات) 2- إزالة (مهم جدا وأعتقد أن هذه هي مشكلتك) تلوين الأسطر الملونة كاملة (جعلها دون لون وليس بالأبيض) وإن شاء الله ستتمكن من إدراج أسطر جديدة... أخوك بن علية1 point