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

السلام عليكم اخوتي الكرام اهدي العمل المتواضع اداة معلومات الموردين Suppliers Info Tool - مفتوح المصدر لكم لعلا هناك من يجده مفيدا. تم تصميمه من قبلي لجهة العمل التي اعمل بها لهذا لك كامل الحرية للاستفاذة منه و تعديله وليس لها اي حقوق. حسابات الدخول User Password ================ admin 123 Log 123 View view بالتوفيق YEM_LOG_DB.accdb

أهلا بك @ابو البشر بالنسبة للرقم (1): المنهج GetRows يعيد عدد من صفوف بيانات الجدول المشار إليه في المتغير الغرضي XLRS. والرقم بين القوسين يبين عدد الصفوف المطلوب إعادتها.. المنهج GetRows يعيد مصفوفة بيانات من حدين؛ الحد الأول يمثل رقم عمود البيانات (الحقل) في الجدول والثاني يمثل رقم الصف البيانات (السجل).. هذه الحدود يبدأ ترقيمها بالرقم 0 يجب اسناد المنهج GetRows إلى متغير مصفوفة بيانات عامة غير معينة الحدود.. وهو هنا RCROW؛ وهو المشار إليه بالرقم (2). وكمثال (0,0)RCROW يعيد قيمة العمود الأول من الصف الأول في جدول البيانات. بالنسبة للرقم (3) :عند تجهال أسماء أعمدة البيانات المستوردة من أكسل يقوم أكسس بوضع أسماء مزيفة تبدأ بـ (F1)؛ و (F) اختصار كلمة Field و(1) رقم عمود البيانات في أكسس.. إذا كانت ورقة البيانات في أكسل تحتوي على أسماء للأعمدة فيمكن تغيير ذلك من خصائص استيراد البيانات؛ إما على مستوى مصنف البيانات أو على مستوى ورقة بيانات محددة... بالنسبة للرقم (4): يمكن الاستغناء عن المحدد، أو توسيع نطاقه.. لكن لا يمكن استخدام نطاقات متعددة في المجال الواحد.. أرجو أن يكون هذا التفسير واضحاً ومفهوماً ..

لا مشكلة اخي العزيز نعم كان هناك اشكالية مع اصدار 2007 وتم عمل تحديث وانتهت المشكله

جرب هذا الملف الكود Option Explicit Sub From_sheet_to_Form() With Sheets("Salim") If .Range("N6") = vbNullString Then Exit Sub .[P8] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,2,0)") .[N8] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,3,0)") .[P10] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,4,0)") .[N10] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,5,0)") .[Q12] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,6,0)") .[O12] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,7,0)") .[M12] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,8,0)") End With End Sub '+++++++++++++++++++++++++++++++++++++++ Sub add_to_data_val() Dim arr(), m%, i%, lr% Dim s As Worksheet Set s = Sheets("Salim") lr = s.Cells(Rows.Count, 1).End(3).Row i = 2: m = 1 Do Until i = lr + 1 If Application.CountIf(s.Range("A2:A" & i), s.Range("A" & i)) = 1 Then ReDim Preserve arr(1 To m) arr(m) = s.Range("A" & i) m = m + 1 End If i = i + 1 Loop ReDim Preserve arr(1 To m) arr(m) = s.Range("N6") With s.Range("N6").Validation .Delete .Add 3, Formula1:=Join(arr, ",") End With s.Range("A" & lr + 1) = arr(UBound(arr)) s.Range("N6") = arr(UBound(arr)) End Sub '++++++++++++++++++++++++++++++++++++++++++++ Sub Form_To_sheet() Dim s As Worksheet Dim rg As Range, RO% Dim lr%, Answer As Byte Set s = Sheets("Salim") lr = s.Cells(Rows.Count, 1).End(3).Row If Application.CountIf(s.Range("A2:A" & lr), s.Range("N6")) = 0 Then Answer = MsgBox("This code dosn't exixts!.. " & Chr(10) & _ "Do you like to add it", 4) If Answer = 6 Then add_to_data_val Exit Sub End If End If Set rg = s.Range("A1:A" & lr).Find(s.[N6], lookat:=1) If rg Is Nothing Then Exit Sub RO = rg.Row With s .Range("A" & RO) = .[N6]: .Range("B" & RO) = .[P8] .Range("C" & RO) = .[N8]: .Range("D" & RO) = .[P10] .Range("E" & RO) = .[N10]: .Range("G" & RO) = .[Q12] .Range("H" & RO) = .[O12]: .Range("I" & RO) = .[M12] End With End Sub الملف مرفق Vice_versa.xlsm

هلا اخي جرب المرفق TEST.accdb

كل عام وحضراتكم بخير ورمضان كريم اعاده الله عليكم وعلى الامة الاسلامية بالخير واليمن البركات البحث فى القرآن الكريم.xlsm

السلام عليكم ورحمة الله وبركاته الاخوة الأفاضل تقبل الله طاعاتكم وجعلنا واياكم في هذا الشهر الكريم من عتقائه من النار. وبعد أحتاج بعض الأفكار لمن سبقني بمجال برامج البيع (كالسوبر ماركت - ونقاط البيع) حيث أن في هذا المجال يكون الصنف به أكثر من وحدات قياس أو تعبأة مثلا صنف كالسكر مثلا وحدة القياس هنا الوزن - وطريقة التغليف تكون علي شكل أكياس كبيرة تحوي 10 أكياس صغيرة من فئة 1 كيلو جرام فاذا كانت الكمية المشتراة مثلا 1 طن فهذا يعني أن الكمية هي عبارة عن 100 كيس كبير (لفة أو شكارة أو أي مسمي قريب مما هو مألوف فأنا لا أدري خارج مصر كيف تكون التسميات) وفي نفس الوقت = 1000 كيس صغير سعة 1ك جرام وهكذا دوليك للاصناف المختلفة في وحدات القياس و التعبأة ونظام التغليف أرجوا ممن له سبق بهذا المجال يفيدني بما منّ الله عليه من طريقة معالجة هذه المسألة عند التعامل مع الكميات المتاحة والمنصرفة والرصيد المتبقي. وجزاكم الله خيرا

السلام عليكم ورحمة الله وبركاته ..... جميع اعضاء المنتدى ..... كل عام وانتم بخير وأسأل الله عز وجل أن يتقبل منا ومنكم صالح الاعمال استفسار حول كود سابق شارك في موضوعة في هذا الموضوع الأساتذة : @فايز و @Barna و @jjafferr و @أبو إبراهيم الغامدي في هذا الموضوع ولدي عدد من الاستفسار على الكود التالي بارك الله فيكم : Option Compare Database Option Explicit Sub IMPORT_XLSDB() On Error GoTo SUB_CLOSE '-- OPEN CURRENT DATABASE AS LOCAL DB Dim DB As DAO.Database Set DB = CurrentDb '-- OPEN RS DB TO ADD DATA Dim DBRS As DAO.Recordset Set DBRS = CurrentDb.OpenRecordset("TABLE") '-- OPEN XLS FILE AS REMOTE DATABASE Dim XLDB As DAO.Database Set XLDB = OpenDatabase( _ CurrentProject.Path & "\CS_SeetNumberLabels2.xlsx", False, False, "EXCEL 12.0;HDR=NO;") '-- OPEN XLS SHEET AS REMOTE RS Dim XLRS As DAO.Recordset Dim RCROW() Dim RC As Long Dim I As Integer Dim TD As DAO.TableDef '-- LOOP THROUGH XLDB TABLES (SHEETS) For Each TD In XLDB.TableDefs '-----------------------------------------------------------------------------------------' '-- RECORDS FROM COLUMN (C) IN XL SHEET Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "C:C]WHERE NOT ISNULL(F1)") '-- COUNT RECORDS XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst '-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS For I = 1 To RC Step 5 RCROW = XLRS.GetRows(5) DBRS.AddNew DBRS![ACADEMIC YEAR] = RCROW(0, 0) DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32))) DBRS![STNAME] = RCROW(0, 2) DBRS![F1] = RCROW(0, 3) DBRS![Sub] = RCROW(0, 4) DBRS.Update Next Set XLRS = Nothing '--------------------------------------------------------------------------------------' '-- RECORDS FROM COLUMN (I) IN XL SHEET Set XLRS = XLDB.OpenRecordset("SELECT F1 FROM [" & TD.Name & "I:I]WHERE NOT ISNULL(F1)") '-- COUNT RECORDS XLRS.MoveLast: RC = XLRS.RecordCount: XLRS.MoveFirst '-- EACH 5 OF XLRS RECORDS MAKE 1 RECORD IN DBRS For I = 1 To RC Step 5 RCROW = XLRS.GetRows(5) DBRS.AddNew DBRS![ACADEMIC YEAR] = RCROW(0, 0) DBRS![ACADEMIC NUM] = Mid(RCROW(0, 1), InStrRev(RCROW(0, 1), Chr(32))) DBRS![STNAME] = RCROW(0, 2) DBRS![F1] = RCROW(0, 3) DBRS![Sub] = RCROW(0, 4) DBRS.Update Next Set XLRS = Nothing Next SUB_CLOSE: '-- COLOSE XLDB AND XLRS Set XLRS = Nothing ' XLDB.Close Set XLDB = Nothing '------------------------' '-- CLOSE DB AND DBRS Set DBRS = Nothing XLDB.Close Set XLDB = Nothing End Sub 1- ما المقصود في الاؤقام المسجلة في 1 و 2 2- ما المقصود ب F1 و هل يمكن تغيير النطاق في 4 وكيف يتم ذلك لو اغترضنا أن ملف الاكسل نريد جلب بيانات اكثر من عامود في الصفحة الواحدة دون تكرار للكود كما فعلنا في الكود السابق بمعنى بجلب بيانات العمود C والعمود I مباشرة أو حتى أكثر من عمودين ؟؟؟؟ بارك الله فيكم وفي علمكم ... الموضوع هنا بارك الله فيكم

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

ما شاء الله عليك .. كفيت ووفيت . .

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

هلا اخي هذا ليس اجابة عن سؤالك ولكم حبيت اشاركك تصميم مراقبة المخزون (متجر بيع بالتجزئة) Inventory Control (Retail Store) لعلى فيه بعض الافكار http://www.databaseanswers.org/data_models/inventory_control_for_retail/index.htm بالتوفيق

بسم الله مشاء الله عليك اخى العزيز جدااااااا احمد الفلاحجى واضح انك خبرة ( خد بالك هستغلك ان شاء الله ) ☺️ وهصدعك لحد ما اخلص البرنامج ❤️ تبعت الموضوع وردك على الاستاذ سيد ونزلت النماذج واحاول ادرسها وان شاء الله هوفيك بالنتيجة الف مليون شكر ليك يابو حميد

أرجو أن أستطيع غدا إن شاء الله تنفيذ طلبك فأنا مرهق الآن ولا استطيع أن أكمل معذرة

السلام عليكم أي من الحقول الخاصة بالعميل تريد أن يظهر مجموعها Qty أم Qty_sals ومن فضلك وما هي المعادلة الرياضية بين كلا من Qty_sals و Qty و unitPrice فانا أري أرقام غريبة لم استطع معرفة العلاقة بينها

وعليكم السلام اخى @ازهر عبد العزيز بهذه العلامه قبل الكتابه ' وتكتب بحرف الطاء وانت عاتجاه الكتابه الانجليزى Private Sub N1_BeforeUpdate(Cancel As Integer) 'هذا السطر لا ينفذ هو للتعليق If IsNull(DLookup("name", "at", "[serial number]='" & Me.B & "'")) Then MsgBox "هذا النص غير موجود بالجدول" Me.Undo ElseIf DCount("*", "ld", "idlh=" & Me.idlh & "and B='" & Me.N1 & "'") > 0 Then Dim stry As String stry = Me.N1 Me.Undo Dim rs As Object Set rs = Me.Recordset.Clone rs.FindFirst "[B] = '" & stry & "'" If Not rs.EOF Then Me.Bookmark = rs.Bookmark DoCmd.GoToRecord , , acNewRec End If End Sub بالتوفيق

رسالة الخطأ تقول بأنها لم تحصل على الدالة isnothing !! فهل هي موجودة في الكود عندك ؟ او يمكن انك نسخت الكود هذا من برنامج آخر ، ونسيت ان تنسخ الدالة isnothing !! وجدت الدالة هنا : https://www.youtube.com/watch?v=MItoTRM8-kw فنسختها من الفيديو وكتبتها هنا لتسهيل الامر ، لهذا السبب فأنا لا علاقة لي مع الدالة 🙂 اعمل وحدة نمطية جديدة ، ثم احفظ هذه الدالة هناك : Public Function IsNothing(ByVal V) As Integer On Error GoTo nerr IsNothing = True Select Case VarType(V) Case 0 'empty GoTo fext Case 1 'null GoTo fext Case 2, 3, 4, 5, 6 'int, long, single, double, currency If V <> 0 Then IsNothing = False Case 7 'date/time IsNothing = False Case 8 'string If (Len(V) <> 0 And V <> " ") Then IsNothing = False End Select fext: On Error GoTo 0 Exit Function nerr: IsNothing = False Resume fext End Function جعفر

الاستاذ المبدع @أحمد الفلاحجى ماشاء اللة ربي يحفظك روعة عدلت قليلا على مثالك وتم الحل الاستاذ @اشرف شكرا لك ماقصرت ربي يحفظكم من كل سوء

جزاك الله خيرا اخى العزيز @اشرف على مشاركتك اتفضل اخى @ازهر عبد العزيز لديك رقم 3 و 5 بجدول at لا يوجد لهم اسم جرب وجرب رقم اخر من المسجلين ووافنا بالنتيجه ان شاء الله يكون ما طلبت بالتوفيق اخوانى TEST1-azhr.accdb

اتفضل جرب كدة TEST1 (4) - Copy(1).accdb ازهر عبد العزيز

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

جرب التالي TEST (1).accdb

الف شكر ياغالي هل بالامكان تلوين الخط بدل تلوين الحقل كاملا ؟

جرب البرنامج التالي https://www.ssesetup.com/

الاخ العزيز @أحمد الفلاحجى و الاخ العزيز @اشرف شكرا بمروركم العطر

السلام عليكم اخي الفاضل ازهر عبد العزيز اخي الفاضل أحمد الفلاحجى اسمحو لي بالمشاركة هل هذا هو المطلوب ام لم افهم المطلوب TEST1 (4) - Copy(1).accdb

وعليكم السلام اخى @ازهر عبد العزيز هل هذا ما تريد ؟ جرب ووافنا بالنتيجه بالتوفيق اخى ازهر TEST1 (4) - Copy(1).accdb

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

جزاك الله خيرا اخى الفاضل @ابو تراب جعله الله فى ميزان حسناتك ان شاء الله تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق اخوك الصغير احمد

اتفضل ان شاء الله يكون ما تريد ومع اذان المغرب والافطار تقبل الله صيامكم لعل انول دعوه صالحه بالتوفيق اخى 333.mdb

وعليكم السلام 🙂 المشكلة مو في فتح التقرير ، ولا متغيرات ، وانما أمر اغلاق النموذج غير كامل ، لذا يجب ان يكون الامر هكذا : DoCmd.OpenReport "report name", acViewPreview DoCmd.Close acForm, "واجهه البرنامج",acsaveno او الافضل ان لا تذكر اسم النموذج بالاسم ، وانما بمناداة اسمه DoCmd.OpenReport "report name", acViewPreview DoCmd.Close acForm, me.name ,acsaveno جعفر

الرساله بتقول عندك متغيير غير متعرف ممكن تضع مثال لما لديك بالتوفيق

وعليكم السلام 🙂 تم نقاش هذا الموضوع في الرابط التالي ، والذي به رابط آخر كذلك : جعفر

لا اعتقد...في انهاية يعتمد على مدى كفائة كتابة الكود و متانة تصميم القاعدة البيانات و العلاقات بين الجداول و طريقة كتابة الاستعلامات.

يا استاذ/ @abo jood اعتقد انك لم تنتبه جيدا لفيديو الاستاذ / بدران يوجد برنامجين اسفل الفيديو قم بتحميلهم تابع الشرح خطوة خطوة وسوف ان شاء الله تصل لهدفك بالتوفيق

هل دا هو المطلوب؟ Book01.xlsx

بعد اذن الاخ رائد هذا الملف تم حماية العادلات لعدم التلاعب بها غن طريق الخطأ My_Book5.xlsx

تفضل Book5.xlsx

مثال تطبيقي حول التعامل مع المتصفح: الدخول إلى موقع أوفيسنا في متصفح Internet Explorer من خلال الأكسس المثال التالي يمكننا من إدخال اسم المستخدم و كلمة مرور أوفيسنا و عند الضغط على زر الدخول يفتح الموقع بحسابك الخاص في متصفح أنترنت أكسبلورر Dim HTMLDoc As HTMLDocument Dim oBrowser As InternetExplorer Dim oHTML_Element As IHTMLElement Dim sURL As String On Error GoTo Err_Clear sURL = "https://www.officena.net/ib/login/" Set oBrowser = New InternetExplorer oBrowser.Silent = True oBrowser.Navigate sURL oBrowser.Visible = True Do ' Wait till the Browser is loaded Loop Until oBrowser.ReadyState = READYSTATE_COMPLETE Set HTMLDoc = oBrowser.Document HTMLDoc.all.auth.Value = Me.str_UserName HTMLDoc.all.Password.Value = Me.str_Password HTMLDoc.getElementById("elSignIn_submit").Click ' oBrowser.Refresh ' Refresh If Needed Err_Clear: If Err <> 0 Then 'Debug.Assert Err = 0 Err.Clear Resume Next End If فتح موقع أوفيسنا.rar

يمكن ذلك لكن عليك وضع القائمة المنسدلة بعيداً عن الجدول (العامود A والعامود V لا يصلحان لانهما ملاصقان للجدول انا اخترت العامود X ) كما ذكرت لك ( دون تدخل خلايا غير فارغة على كل حدود الجدول) الماكرو: Sub MY_Test_CHOOS_FILTER() Dim ws As Worksheet Dim sh As Worksheet Dim lr As Long Set ws = Sheets("DATA") Set sh = Sheets("AS") With Application .Calculation = xlCalculationManual .ScreenUpdating = True End With On Error Resume Next With sh .Range("B2:U1026").Clear ws.Range("B7:U1026").Copy .Range("B2").PasteSpecial xlPasteValues .Columns(5).Replace 0, "" .Columns(5).SpecialCells(4).EntireRow.Delete .Range("B1").CurrentRegion.Sort _ Key1:=sh.Range(Range("X1")), Order1:=1, Header:=1 .Range("M:L").NumberFormat = "d/m/yyyy" End With On Error GoTo 0 With Application .CutCopyMode = False .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Range("B3").CurrentRegion.Borders.Value = 1 Range("B3").CurrentRegion.Offset(1).InsertIndent 1 sh.Range("B1").Select End Sub الملف مرفق Extract_WITH_CHOOSEN_FILTER.xlsb

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

السلام عليكم ___________________.rar