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

السلام عليكم ورحمة الله وبركاته انا احد الاشخاص الذين لا يحبذ ان يستعمل الكود في تخفيف أمان الاكسس ، فقد وضعته شركة مايكروسوفت في حزمة الاوفيس حتى تحمينا من ايدي المخربين ، وفي هذا الرابط شرحت كيفية عمل مجلد موثوق به للأكسس 2007 فما فوق: http://www.officena.net/ib/topic/66450-دمج-ملف-وتشغيله-قبل-أو-مع-بدء-اكسس/#comment-432363 المشكلة في كود تخفيف الامان ، انه لا يخفض مستوى أمان الاكسس لبرنامجك فقط ، وانما يخفض مستوى أمان جميع برامج الاكسس. ولكننا كمبرمجين لدينا مشكلتنا ، في انه اذا ارسلت برنامجك الى شخص ما ، فلا بد من التواصل معه و اعطاؤه الخطوات كما في الرابط ، وإلا فالبرنامج لن يعمل ، لان البرنامج يشتمل على الماكرو والوحدات النمطية. هنا اقدم لكم طريقة لجعل برنامجي فقط يعمل بمستوى أمان أقل ، فلا تظهر لي رسالة الأمان من الاكسس. العمل كله يدور حول كود ، ويجب حفظ الكود هذا في ملف بصيغة vbs ، والذي يجب ان نفتح برنامجنا عن طريقه. الكود يعمل على برامج الاكسس بصيغة mdb و accdb ، والمفروض ان يعمل على جميع اصدارات الاكسس 2003 فما فوق ، وعلى الاكسس 32بت و64بت (انا هنا اطلب من الشباب تجربته بإصدارات الاكسس التي يعملون عليها ، وإخبارنا بالنتيجة لوسمحتوا). اليكم طريقة العمل (رجاء انزال المرفق وفكه في المسار C:\jj ، وذلك حتى يمكنكم متابعة خطواتي): رجاء وضع البرنامج المرفق Seq.mdb حسب المسار التالي: C:\jj\Seq.mdb الآن اذهب الى المجلد C:\jj وافتح البرنامج Seq.mdb بالنقر المزدوج ، عند فتحه نرى رسالة أمان الاكسس ، وهذا متوقع ، وذلك بسبب انه في مجلد غير موثوق به (رجاء لا تضف هذا المجلد كمجلد أمان ، وانما اخرج من البرنامج). . الملف الآخر المرفق Seq.vbs ، يحتوي على هذا الكود: rem http://www.accessmvp.com/jconrad/accessjunkie/macrosecurity.html rem expression.OpenCurrentDatabase(filepath required, Exclusive optional, bstrPassword optional) dim o set o=createobject ("Access.Application") o.automationsecurity=1 ' set macro security LOW. o.opencurrentdatabase "C:\jj\Seq.mdb" o.usercontrol=true set o=nothing . تستطيع ان تجعله في اي مجلد (ممكن تجرب نسخه منه في اي مجلد شئت) ، وانقر مرتين على هذا الملف بُغية تشغيله ، سترى انه فتح البرنامج Seq.mdb ، وبدون رسالة أمان الاكسس ، وهو المطلوب ------------------------------------------------------------------------------------------------------------------------------------------- هذه الخطوة إضافية ، وهي لتحويل الملف السابق من صيغة vbs الى exe ، واختيار ايقونه للملف الجديد الآن ننتقل للخطوة التالية ، وهي ، اننا لا نريد ان ايقونة vbs ، وانما نريد ايقونه خاصة لبرنامجنا. هناك طريقتين: 1. ايقونة مختصر البرنامج Shortcut: وهي ان نعمل مختصر لملف Seq.vbs ، ولكن وللأسف مختصر ملف vbs يعطينا نفس ايقونة الملف نفسه ، وما عندنا طريقة لتغييرها!! لذلك ، سنعمل مختصر لملف الاكسس ، ونغير البيانات كالصورة التاليه ، بحيث يصبح مختصر ملف vbs يحتوي على ايقونة ملف الاكسس (طبعا يمكنك ان تغير الايقونة الى اي شئ شئت): . . . . وبهذه الطريقة غيّرنا ايقونة برنامج vbs الى ايقونه اخرى مناسبة 2. تحويل ملف vbs الى ملف تنفيذي exe ، وتختار له الايقونة التي تعجبك: رجاء انزال البرنامج المجاني Vbs to Exe من الرابط التالي: http://www.f2ko.de/en/v2e.php احد اسباب اختياري لهذا البرنامج ، اننا نستطيع التحكم به عن طريق Commandline ايضا ثم نتبع الخطوات التالية: ونستطيع ان نعمل لبرنامج vbs هذا كلمة سر كذلك ، . في الخطوة 6 تستطيع ان تكتب معلومات شركتك ، ونختار الايقونه التي نريدها للبرنامج (الخطوة 5) . . وتستطيع ان تجعله على سطح مكتب كمبيوترك الميزة في هذه الطريقة ، ان المستخدم لن يعرف مكان برنامج قاعدة البيانات Seq.mdb ، ولن يعرف الكود الذي كان في Seq.vbs ارجو ممن يضع ردا على الموضوع ، ان يذكر: 1. اذا اشتغل البرنامج على كمبيوتره ، 2. نسخة الاكسس التي يستخدمها. ملاحظة: الظاهر ان بعض متصفحات الانترنت حجبت انزال المرفق Seq.zip ، وذلك بسبب احتوائه على ملف vbs ، والذي يستخدمه الكثيرون لتخريب الكمبيوتر ، لذلك ، ارفق لكم Seq_2.zip والذي يحتوي على نفس ملفات Seq.zip ، ولكني غيرت صيغة الملف Seq.vbs الى Seq.txt . بعد انزال المرفق وفك ملفاته في الكمبيوتر ، رجاء تغيير مسمى الملف Seq.txt الى Seq.vbs جعفر Seq.zip Seq_2.zip

كثر الحديث والطلب عن هذا الموضوع (استخراج الارقام أو الأحرف او الكلمات من نص) لذلك قمت بتحميل هذا الملف الذي عسى ان يستفيد منه اكبر عدد ممكن من الاعضاء الملف يحتوي على دالّة معرفة Option Explicit Function Salim_Single_Match(aString As String, my_expression As String, n%) As Variant Dim RegEx As New VBScript_RegExp_10.RegExp Dim NowArray() As String Dim Match, matches As Object Dim x%, cnt% With RegEx .Pattern = my_expression .Global = True .IgnoreCase = True End With On Error Resume Next Set matches = RegEx.Execute(aString) x = matches.Count If x = 0 Then Error.Clear Salim_Single_Match = "No Match": Exit Function End If ReDim NowArray(x - 1) For Each Match In matches NowArray(cnt) = Match.Value cnt = cnt + 1 Next If n > cnt Then n = cnt Salim_Single_Match = NowArray(n - 1) End Function salim_UDF_Formula.xlsm

انت تدرج الوقت بشكل خاطىء في الخلايا (حيث اكسل لا يمكنه التعرف عليه) لذلك قمت بعمل هذا النموذج فيه شرح لكيفية ادراج الوقت والمعادلات اللازمة مع حرية اختيار وقت العمل (من الى) وتغيير المكافأة الى الرقم الذي تريد ليس فقط 15 دقيقة المعادلات محمية لعدم العبث بها عن طريق الخطأ /عسى ان ينال الاعجاب Time_calculation.xlsx

شوف المرفق Update22-3.accdb

هل هذا ينفع SELECT Information.ID, Information.Name, Information.[Date of commencement of work], Nz(DLookUp("[Skills]","[Skills]","[ID]=" & [ID])) AS Skills FROM Information;

السلام عليكم آسف للتأخر بالرد فانا ازور المنتدى بأيام العطلات تفضل جرب هذا لعله يوافق مرادك IportExportAttachment.rar

السلام عليكم ليس لدي مثال محدد و إنما هو سؤال عام عن وجود مقابل للدالة & و الإجابة التي حصلت عليها لا يوجد و لكن لمزيد من التأكد طرحت السؤال هنا.

ممكن ارفاق مثال

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

لك ما تريد Hidden_rows .xlsm

تم معالجة الامر لا تختفي الصفوف الا اذا كان الصف من ( A ِ الى D ) مكتملاً ( 4 عناصر) Code Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("a2:d99")) Is Nothing _ And Application.CountA(Range(Cells(Target.Row, 1), Cells(Target.Row, 4))) = 4 Then hid_My_row (Target.Row) End If End Sub Rem++++++++++++++++++++++++++++++++++ Sub hid_My_row(k%) Rows(k + 2 & ":" & 104).Hidden = True Rows(1 & ":" & k + 1).Hidden = False Cells(k + 1, 1).Select End Sub Rem++++++++++++++++++++++++++++++++++ Sub SHOW_ME() Rows(1 & ":" & 105).Hidden = False End Sub Rem++++++++++++++++++++++++++++++++++ hide_Any_wher_ROWS.xlsm

تابع هذه الصورة

تفضل Print_vis_ROWS.xlsm

جرب هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim x If Target.Column = 1 And _ Target.Count = 1 And Target.Row < 100 Then x = Range("A:a").Find("", after:=Cells(1, 1)).Row hid_My_row (x) End If End Sub Rem++++++++++++++++++++++++++++++++++ Sub hid_My_row(k%) Rows(k + 1 & ":" & 100).Hidden = True Rows(1 & ":" & k).Hidden = False Cells(k - 1, 1).Offset(, 1).Select End Sub Rem++++++++++++++++++++++++++++++++++ Sub SHOW_ME() Rows(1 & ":" & 100).Hidden = False End Sub Rem++++++++++++++++++++++++++++++++++ الملف للتجربة مرفق SHOW_HIDE_ROWS.xlsm

السلام عليكم جازانا الله وإياك، ماذا تقصد بجعل النتائج مرقمة؟ هل تقصد أن تكون النتائج في الليست بوكس كما يلي : 1) 7881 2) 2220 3) 8769 ... بن علية حاجي

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

السلام عليكم تعديل آخر على الملف بإدراج كود بسيط (حسب معرفتي البسيطة بالأكواد) وأرجو أن يفي الغرض المطلوب... الكود وُضع في حدث الورقة "بحث" بحيث بمجرد التغيير في الخلية C1 (رقم السيارة) يجلب بصفة تلقائية كل البيانات الخاصة بهذه السيارة من كل الجداول في شيت "المواقف"... وأرجو أيضا أن يحسّنه (الكود) أحد الإخوة المتمكنين بـ VBA أو يبدله بأحسن وأسرع منه.. ملاحظة: تم إرفاق الملف الخطأ في ردي السابق وأعتذر من الإخوة الذين قاموا بتحميله... قد أعدت إرفاق الملف الصحيح... بن علية حاجي بحث في كل الجداول.xlsm

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

أخي العزيز أحمد الفلاحجي لا تعلم مدى المعاناة التي عانيتها مع ملفاتك خصوصاً الملف المسمى "البيان" .. لا أعلم عندما قمت بعمل معاينة وجدت حوالي 1180 ورقة .. حاولت التخلص من البيانات الزائدة وعند حذف الأعمدة الزائدة يهنج الأوفيس ويغلق الملف وحاولت مراراً وتكراراً إلى أن تخلصت من هذه المشكلة وأبقيت على الأعمدة المطلوبة فقط في النطاق A1:Q عموماً جرب الكود التالي ..عله يفي بالغرض (رغم أن معادلاتك تعمل بشكل جيد كما لاحظت إلا أنني أفضل استخدام الأكواد نظراً لما تسببه المعادلات من ثقل في الملف خصوصاً مع البيانات الكثيرة) Sub ImportDataFromClosedWBUsingVLOOKUP() Dim WBK As Workbook Dim Rng As Range Dim LastRow As Long Dim I As Long Application.ScreenUpdating = False Application.DisplayAlerts = False With ThisWorkbook.Sheets("Sheet1") Set WBK = Workbooks.Open(ThisWorkbook.Path & "\NewAll\7-2015.xlsx") Set Rng = WBK.Sheets("Sheet1").Range("G2:J" & Cells(Rows.Count, "G").End(xlUp).Row) LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row .Range("F3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",4,False),"""")" .Range("P3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",3,False),"""")" WBK.Close SaveChanges:=False '================================================================================================================ Set WBK = Workbooks.Open(ThisWorkbook.Path & "\NewAll\6-2015.xlsx") Set Rng = WBK.Sheets("Sheet1").Range("G2:S" & Cells(Rows.Count, "G").End(xlUp).Row) .Range("E3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",10,False),"""")" .Range("G3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",12,False),"""")" .Range("H3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",3,False),"""")" .Range("I3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",13,False),"""")" For I = 1 To 6 .Cells(3, I + 9).Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP($A3," & Rng.Address(, , , True) & "," & I + 3 & ",False),"""")" Next I .Range("Q3").Resize(LastRow - 1).Formula = "=IFERROR(VLOOKUP(A3," & Rng.Address(, , , True) & ",11,False),"""")" .Range("E3:Q" & LastRow).Value = .Range("E3:Q" & LastRow).Value WBK.Close SaveChanges:=False End With Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub وإليك الملف المرفق فيه تطبيق للكود وتم ضبط الملف الرئيسي "البيان" وجعلته بعنوان جديد (يمكنك تغيير اسمه لاسم "البيان" مرة أخرى ..لن يؤثر على عمل الكود) تقبل تحياتي Import Data From Closed Workbooks Using VLOOKUP Flahgy.rar

الأخ الحبيب أحمد مرجان نعتذر عن التأخير في تقديم المساعدة (وكل تأخيرة فيها عطلة للناس بس أكيد فيها خيرة بردو) إليك الكود التالي (وعشان غرامة التأخير مرفق شرح لكل أسطر الكود عشان تقدر تعدل بما يناسبك إن شاء الله) Sub ImportDataFromClosedWBUsingVLOOKUP() 'تعريف المتغيرات Dim WBK As Workbook Dim Rng As Range Dim LastRow As Long 'إيقاف تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'إيقاف خاصية رسائل التنبيه Application.DisplayAlerts = False 'ليساوي المصنف المسمى 1 والموجود في نفس مسار المصنف الحالي [WBK] تعيين قيمة للمتغير 'يقوم هذا السطر أيضاً بفتح المصنف في المسار المذكور Set WBK = Workbooks.Open(ThisWorkbook.Path & "\1.xlsx") 'تعيين قيمة للنطاق المراد جلب البيانات منه من المصنف المسمى 1 Set Rng = Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row) '[Sheet1] بدء التعامل مع المصنف الحالي في ورقة العمل With ThisWorkbook.Sheets("Sheet1") 'تحديد رقم صف آخر خلية بها بيانات في العمود الأول LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'وضع معادلة دالة البحث في العمود الثاني والحصول على النتيجة من العمود الثاني في المصنف 1 With .Range("B2").Resize(LastRow - 1) .Formula = "=IFERROR(VLOOKUP(A2," & Rng.Address(, , , True) & ",2,False),"""")" .Value = .Value End With 'وضع معادلة دالة البحث في العمود الثالث والحصول على النتيجة من العمود الثالث في المصنف 1 With .Range("C2").Resize(LastRow - 1) .Formula = "=IFERROR(VLOOKUP(A2," & Rng.Address(, , , True) & ",3,False),"""")" .Value = .Value End With End With 'إغلاق المصنف المأخوذ منه البيانات بدون حفظ WBK.Close SaveChanges:=False 'إعادة تفعيل خاصية رسائل التنبيه Application.DisplayAlerts = True 'إعادة تفعيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub وبكدا نكون دفعنا غرامة التأخير والحمد لله تقبل تحياتي Import Data From Closed WB Using VLOOKUP YasserKhalil.rar