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

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

وعليكم السلام 🙂 جرب هذا الكود: =IIf(IsError([Text61]-[Text63]);"";[Text61]-[Text63]) جعفر

السلام عليكم 🙂 نعمل البرنامج ، ثم نقسمه الى قسمين ، FE الواجهة و BE الجداول ، ولما نعطيه للمستخدم ، نربط الجداول بمسار خاص به ، ويعمل البرنامج. ولما المستخدم يحتاج الى تعديل/اضافات ، ويرسل لنا نسخته بالايميل (انا ممكن اكون مسافر وبعيد عن نسختي) ، فيجب علينا ان نغير مسار الجداول ليتناسب مع مجلدات الكمبيوتر عندنا ، ولما ننتهي من التعديل ، نرسله بالايميل ، وهناك يجب على المستخدم ان يغير المسار الى ذلك الذي به BE الاصل 🙂 المشكلة انه: 1. بعض الاوقات نكون قد وضعنا الـ BE في مكان لا يجب ان يعرفه المستخدم ، فلا نريد تدخل منه لهذا التغيير ، 2. بعض الاوقات المستخدم لا يعرف مكان الـ BE اصلا ، 3. وبعض الاوقات ، المستخدم لا يكون فني ليعرف كيف يختار مكان الـ BE 🙂 صادفتني هذه المشكلة مراراً ، ومرة دفعت الثمن غالي لما ربطوه بالـ BE الغلط ، ربطوه بنسخة الـ Backup بدل عن النسخة الاصل 😁 الى ان اهتديت الى هذه الطريقة 🙂 الفكرة هي عبارة عن اضافة جدول tbl_ReLink_To_Original في الـ FE فيه سجلين ، سجل يحتوي على مسار BE المستخدم ، وسجل يحتوي على مسار BE المبرمج ، وبدل هذا الجدول ، ممكن ان نضع ملف نص txt في مجلد FE ، ونكتب فيهم السجلين ، ثم نقرأهم ، ولكن الجداول في الـ FE تناسبني اكثر ، فإستعملتها 🙂 1. لمعرفة مسار BE المستخدم: . . ثم ننسخه من (1) جدول MSysObjects الى السجل الاول (Seq = 1) في جدولنا (2) tbl_ReLink_To_Original . ثم في السجل الثاني (Seq = 2) ، نكتب مسار الـ BE حسب مجلدات الكمبيوتر عندنا (3) . طريقة العمل: نعمل ماكرو Macro باسم Autoexec ، والذي يقوم الاكسس بفتحه وتنفيذ اوامره اول ما يفتح البرنامج ، 1. نقوم بتشغيل الكود الذي سيربط الـ BE الى المسار الصحيح للمستخدم (اما المبرمج فلا يسنخدم هذا الماكرو ، وانما يدخل في البرنامج بمسك مفتاح الشفت) ، 2. اذا لم يحصل البرنامج على المسار الصحيح ، فيجب ان نخبره ان يعطينا نافذة نختار منها المسار الصحيح ، وهناك عدة طرق ، واخترت طريقتي هنا ، 3.4.5.7.8 هذه لإخفاء جميع كائنات البرنامج من جداول واستعلامات ونماذج وماكرو وتقارير ووحدات نمطية ، وتوسيع البرنامج لحجم الشاشة (فلا نحتاج ان نجعل النموذج منبثق ، والذي به الكثير من المشاكل) ، 5. فتح النموذج الاول من البرنامج ، . هذه هي الوحدة النمطية التي تقوم بالعمل (1) اعلاه : Public Function f_ReLink_To_Original(Optional Seq As Integer = 1) 'On Error GoTo err_f_ReLink_To_Original On Error GoTo Exit_f_ReLink_To_Original ' ' The client have his own path to the linked BE tables, ' yet for Development when we want to do change and modifications on the FE, ' we want to link this FE to our local BE tables, for testing, ' and we are done, we will send this FE back to the client, which will have our BE path!! ' ' Although the FE have a code on startup, which will prompt for the new BE path, but not all clients know how to use it!! ' So I added a table tbl_ReLink_To_Original to the FE, and the path to the client BE path, as Seq = 1 , ' and for the Developer BE, the Seq is 2 or other numbers. ' ' for the Development BE path, we call this Function, for the immediate window: ' ?f_ReLink_To_Original(2) ' ' or from a normal Event: ' Call Call f_ReLink_To_Original(2) ' ' and enter the DB with Shift key, ' ' and when the FE goes to the client, this Function will call Seq = 1 by default, thus returning their correct Path. ' ' ' by jjafferr ' ' v1. 24-Feb-2020 ' Dim db As dao.Database Dim tdf As dao.TableDef Dim ConnectionString As String, Linked_Connection As String Set db = CurrentDb 'which BackEnd the user selected ConnectionString = DLookup("[DB_Path]", "tbl_ReLink_To_Original", "[Seq]=" & Seq) 'the existing BackEnd Linked_Connection = DLookup("[Database]", "MSysObjects", "[flags] = 2097152") 'if the existing BackEnd = User Selected, then No need to connect again, just exit If ConnectionString = Linked_Connection Then GoTo Exit_f_ReLink_To_Original For Each tdf In db.TableDefs ' Only make a change if the table is a linked table If Len(tdf.Connect) Then tdf.Connect = ";DATABASE=" & ConnectionString tdf.RefreshLink End If Next Exit_f_ReLink_To_Original: Exit Function err_f_ReLink_To_Original: If Err.Number = 3170 Then 'MsgBox "رجاء التاكد من مسار القاعدة الموجوده في الجدول" & vbCrLf & "tbl_ReLink_To_Original" 'Resume Next Resume Exit_f_ReLink_To_Original Else MsgBox Err.Number & vbCrLf & Err.Description Resume Exit_f_ReLink_To_Original End If End Function . اما للمبرمج ، فيجب عليه ان يدخل الكود ويكتب (لاحظوا اننا استخدمنا الرقم Seq = 2 ، ليشير الى السجل الثاني في الجدول ، المشير الى مسار الـ BE حسب مجلدات الكمبيوتر عندنا (3) : من نافذة الكود السفلى: immediate ?f_ReLink_To_Original(2) او من اي حدث Call f_ReLink_To_Original(2) . واذا اردت الاستفادة من هذه الطريقة لبرامجك ، فيجب عليك استيراد هذه الكائنات الى برنامجك (مع الاخذ في الاعتبار تغيير اسم النموذج في ماكرو autoexec ) : جعفر Relink Tables.zip

اذا اردت ان تحدد الصفوف المكررة في جدول ما اليك هذا الملف Find_dup_rows.xlsm

بعد اذن المشاركين احبابي الكرام ...... تفضل ملفك بعد التعديل .... ‏‏Library - نسخة.rar

برنامج بسيط للحضور والانصراف ان شاء الله يعجبكم الباسوورد 2545 برنامج الحضور والانصراف.rar

أحسنت استاذ سليم دائما مبدع -بارك الله فيك وزادك الله من فضله ووسع الله فى رزقك

جزاك الله كل خير وزادك الله من فضله

جزاك الله خير الثواب

الحمدلله تم التوصل الي حل من خلال سيكول سيرفر الف شكر لكم جميعا ولو حد عنده نفس المشكله سوف اشرح له الحل

اخواني الافاضل اشكركم جميعا وزادكم الله علما ونفع بكم اجمعين

بار الله فيك

مرحبا انا حاليا في اجازة ولا يتوفر لدي برنامج اكسس على العموم معايير دوال التجميع تختلف عند التعامل مع الارقام والنصوص طالما انك غيرت نوع الحقل الى رقم فممكن تعديل الكود للحقل نص 62 العلوي الاعلى الى التالي =DSum("[debit]";"daily";"[date]<" & DateFormat([Date]) & "And [code]=" & [code]) وكذلك الكود للحقل المسمى نص 62 السفلي الى =DSum("[credit]";"daily";"[date]<" & DateFormat([Date]) & "And [code]=" & [code]) وكما اخبرتك سابقا يمكن الاستغناء عن الحقلين بدمج الكود مباشرة في الحقل الخاص بالرصيد ليكون على النحو التالي =DSum("[debit]-[credit]";"daily";"[date]<" & Format([Date];"\#mm\/dd\/yyyy\#") & "And [code]=" & [code]) تحياتي

لقد وضعت ملفاً بهذا الموضوع قبل ان ترفع مثالك ارجو ان يكون المطلوب الكود Option Explicit Sub Copy_By_Choise() Rem Created By Salim Hasbays On 1/3/2020 Application.ScreenUpdating = False On Error GoTo End_Me Dim S As Worksheet, T As Worksheet Dim i%, col%, X%, Last%, m%, k%, Howmay_row% Dim Title_arr Set S = Sheets("Source"): Set T = Sheets("Target") col = T.Cells(2, Columns.Count).End(1).Column If col = 1 Then col = 500 Howmay_row = S.Range("G2") Title_arr = Application.Transpose(S.Range("a1:d1")) Title_arr = Application.Transpose(Title_arr) Last = S.Cells(Rows.Count, 2).End(3).Row T.Range("A2").Resize(Last, col).Clear m = 3: k = 1 For i = 2 To Last For X = 0 To 3 T.Cells(m, k).Offset(, X) = _ S.Cells(i, 1).Offset(, X) Next X m = m + 1 If m Mod (Howmay_row + 3) = 0 Then m = 3: k = k + 5 Next i col = T.Cells(3, Columns.Count).End(1).Column For k = 1 To col Step 5 Cells(2, k).Resize(, 4) = Title_arr With T.Range("B2").Offset(, k - 1).CurrentRegion .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .InsertIndent 1 End With Next Erase Title_arr: Set S = Nothing: Set T = Nothing End_Me: Application.ScreenUpdating = True End Sub الملف مرفق Split_table.xlsm

ارفع مثالاَ عما تريده

السلام عليكم ورحمة الله تفضل يمكنك اختيار الاسماء من القائمة المنسدلة بورقة البيان و الكود سيعمل وحدة بيان حالة.xls

وعليكم السلام 🙂 رجاء عمل التالي: 1. ادخل بيانات في جدول الاشهر ، وبيانات اخرى في الجداول الاخرى حسب الحاجة ، 2. ماهي العلاقة بين جدول الاشهر وبقية الجداول ؟ ثم على اساس هذه البيانات ، اعمل يدويا النتيجة التي تريدها على اكسل ، وارفق لنا كل ذلك ، وان شاء الله خير 🙂 جعفر

السلام عليكم اخي الكريم emam1424 بعد اذن الاخ الاستاذ kanory تفضل الملف بعد التعديل وتم استيراد ملف الاكسل ضمن مسار قاعدة البيانات وبنفس الاسم الموجود بالكود بنجاح تحياتي ملاحظه / اذا تكرر التسلسل عندك ستظهر لك رسالة لكونه مفتاح اساسي Library - نسخة.rar

السلام عليكم ورحمة الله استخدم هذا الكود Sub SelCase() For i = 7 To 1000 If Not IsNumeric(Cells(i, "EU")) Then Cells(i, "DS") = Cells(i, "EU") ElseIf Cells(i, "FO") = 0 Then Cells(i, "DS") = "ناجح" ElseIf Cells(i, "FO") <= 2 Then Cells(i, "DS") = "دور ثان" Else Cells(i, "DS") = "راسب" End If Next End Sub

هل اسم ملف الاكسل هو نفس الاسم الموجود في الصورة .......

الحمد لله

السلام عليكم ورحمة الله وبركاته 🙂 عندما يكون برنامج الاكسس يعمل ، وفجأة بدأ بإعطاء رسائل خطأ وبدون اي تعديل في البرنامج ، او عند عمل تعديل على البرنامج يُغلق الاكسس: . طريقة العمل: سيفتح البرنامج ، ويجب عليك غلقه ، الى ان لا يفتح تلقائيا مرة اخرى. ولكن ، يجب دائما اخذ الاحتياط وعمل نسخة من البرنامج قبل عمل هذه الخطوات. اقدم لكم شرح بسيط عن الموضوع: في الكثير من الاوقات ، لما نعمل الكود ، نقوم بتعديل وتغيير وتضبيط الكود عدة مرات ، ولكن الاكسس في بعض الاحيان يبقى محتفظ بالكود القديم في ذاكرته !! لذلك : 1. اثناء البرمجة ، وبشكل يومي اقوم بتشغيل هذا الملف المرفق ، 2. وقبل تسليم البرنامج الى الزبون ، اقوم بتشغيل الملف للمرة الاخيرة ، واجهز البرنامج لتسليمه الى الزبون وهذا هو الكود المعدل عن النسخة السابقة: Private Sub cmd_Decompile_Click() Dim MSAccPath As String Dim RegKey As String Dim WSHShell 'As Object Dim waitOnReturn As Boolean: waitOnReturn = True ' Get MSACCESS.exe directory from the Registry RegKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\" & _ "CurrentVersion\App Paths\MSACCESS.EXE\Path" Set WSHShell = CreateObject("WScript.Shell") ' Get parent directory MSAccPath = WSHShell.RegRead(RegKey) ' Decompile WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /decompile", , waitOnReturn ' compact WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /compact", , waitOnReturn ' cmd compile WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /cmd compile", , waitOnReturn ' compact WSHShell.Run Chr(34) & MSAccPath & "MSACCESS.EXE" & Chr(34) & " " & Chr(34) & Me.str_File_Single & Chr(34) & " /compact", , waitOnReturn ' Clear shell var Set WSHShell = Nothing End Sub جعفر Decompile_2.zip

اخى عبداللطيف على ما اعتقد انك رفعت المثال قبل الحفظ حيث انه ليس هناك اى تغيير حدث اخى @رعد داود ركز معى بارك الله فيك وجزاك الله خيرا فى يد العون والمحاوله لاخوانك توضيح لكى تعم الفائده DLookup("[user]", "Pass", "[Pass]= [n2] and [user]= [مربع_تحرير_وسرد62]") المفروض انك عاوز تجيب الباس الخاص وتختبره هل هو ده ام لا لكن انت عكست ثم قمت بالاختبار على اساس عدم مساوه المتغير بصفر Dim X X = Nz(DLookup("[user]", "Pass", "[Pass]= [n2] and [user]= [مربع_تحرير_وسرد62]"), 0) If X <> 0 Then UserName = X DoCmd.OpenForm "main" DoCmd.close acForm, "systempass" Else MsgBox "كلمة المرور غير صحيحة", vbInformation, "رسالة خطأ" DoCmd.OpenForm "changepass" والله اعلى واعلم تقبلوا تحياتى وتمنياتى لكم وللجميع بالتوفيق

شكراً استاذ محسن و لي انا بهذا الشأن هذا الماكرو (عسى ان ينال الإعجاب) Option Explicit Sub S_H_Test_NEW() Dim D As Worksheet: Set D = Sheets("Data") Dim M As Worksheet: Set M = Sheets("المطلوب") Dim ARR(): ARR = Array("S", "G", "C", "H") Dim Obj As Object, i%, Chek%, t% Set Obj = CreateObject("Scripting.Dictionary") M.Range("K2").CurrentRegion.ClearContents i = 2 Do Until D.Range("F" & i) = vbNullString For t = 1 To 4 Chek = Chek + (UCase(M.Cells(2, t)) = _ UCase(D.Cells(i, ARR(t - 1)))) Next If Chek = -4 Then _ Obj.Add i, D.Cells(i, "F") i = i + 1: Chek = 0 Loop If Obj.Count Then _ M.Cells(2, "k").Resize(Obj.Count) = _ Application.Transpose(Obj.items) Set Obj = Nothing: Set D = Nothing: Set M = Nothing Erase ARR End Sub الملف من جديد MY_search_MD_SH.xlsm

اتفضل ان شاء الله يظبط معك غير text لاسم حقل النص لديك If Not IsNull(text.n) Then Me.[conform_zabon].Form.Filter = " [text] ='" & text.n & "'" Me.[conform_zabon].Form.FilterOn = True Else: IsNull (text.n) Me.conform_zabon.Form.FilterOn = False End If اخبرنا بالنتيجه بالتوفيق ان شاء الله

مبدع دائما أستاذنا الكبير / سليم وإثراء للموضوع يمكن تجربة الكود التالى لاستدعء البيانات بأكثر من شرط Option Explicit Sub M_D_Test() Dim ws As Worksheet: Set ws = Sheets("Data") Dim sh As Worksheet: Set sh = Sheets("المطلوب") Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim lr As Long, I As Long, j As Long, P As Long lr = ws.Range("C" & Rows.Count).End(xlUp).Row '------------------------------------ Application.ScreenUpdating = False sh.Range("H2:H22").ClearContents Arr = ws.Range("A2:Z" & lr).Value '=================== Arr1 = Array(5) '==================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For I = 1 To UBound(Arr) ' الـ 3 شروط ' ================================================================================================== If Arr(I, 19) = sh.[A2].Value And Arr(I, 7) = sh.[B2].Value And Arr(I, 3) = sh.[C2].Value Then '================================================================================================== P = P + 1 For j = 0 To UBound(Arr1) Temp(P, j) = Arr(I, Arr1(j)) Next j End If Next I If P > 0 Then sh.Range("H2").Resize(P, UBound(Temp, 2)).Value = Temp '------------------------------------ Application.ScreenUpdating = True End Sub MY_search_MD.xlsm

المنتدى مليئ بشريط للتحميل مثلا انظر .....

تفضل بعد اذن الأستاذ فايز problem sum if green erorr2.xls

تفضل لك ما طلبت Data.xlsm

بارك الله فيك وزادك الله من فضله

تفضل اخى الكريم فمثلا هذه هى معادلة جلب اسم الموظف من رقمه =INDEX(staff!$B$3:$B$7,MATCH(C1,staff!$A$3:$A$7,0)) اول جزء من المعادلة وهو Index لابد ان يأتى بعدها عمود البيانات المطلوبة , وبما ان عمود اسماء الموظفين الموجود بصفحة Staff هو العمود الثانى أى عمود B ويبدأ من الخلية B3 ..فاصبح نطاق هذا العمود من B3:B7 او الى اخر خلية تريدها وبها بيانات فممكن الى B500 فليس هناك مشكلة فى هذا أما بالنسبة للجزء الثانى من المعادلة بعد وضع هذه العلامة , أو المنقوطة ; حسب اعدادات الكمبيوتر لديك فهناك باقى شرط المعادلة لإيجاد الناتج وهو Match ثم بعد القوس يتم وضع رقم الخلية للبند ان نبحث به وهو رقم الموظف بصفحة Info وتكون فى المعادلة C1 ثم يتم وضع فاصة , وبعد ذلك يوضع نطاق عمود أرقام الموظفين من الصفحة الأخرى Staff ويكون العمود الأول A وكما اتفقنا يبدأ نطاق الجدول من الصف الثالث فتكون A3 : A500 مثلا ثم بعد ذلك وضع فاصة كمان , ثم الرقم 0 صفر وبعد ذلك غلق قوسين الأول لـ Match والثانى يخص جزء Index وبكده تكون انتهت المعادلة بارك الله فيك

تفضل لك ما طلبت Data Entry.xlsm

أحسنت أستاذ عبد اللطيف عمل رائع بارك الله فيك

وعليكم السلام-اخى الكريم وبما انك لم تقم برفع ملف للمطلوب فكان عليك استخدام خاصية البحث بالمنتدى فقد تم تناول هذا الموضوع قبل ذلك كيف يقوم اكثر من مستخدم بالتعديل على ملف اكسيل فى وقت واحد ؟ أرجو المساعدة

بارك الله فيك هدية بالطبع مقبولة ,جزاك الله خير الثواب

بارك الله فيك وزادك الله من فضله ورحم الله والديك

وعليكم السلام-يمكنك تطويع هذا الكود Option Explicit Option Base 1 Sub Wsh_CopyTo_NewWbk() Dim aWsh As Variant aWsh = [{"Sheet1","Wsh1";"Sheet2","Wsh2"}] Dim aWshSrc(2) As Worksheet Dim wbk As Workbook, wsh As Worksheet Dim vItm As Variant, b As Byte Rem Set Worksheet Array With ThisWorkbook For b = 1 To UBound(aWsh) .Worksheets(aWsh(b, 1)).Unprotect Password:=aWsh(b, 2) Set aWshSrc(b) = .Worksheets(aWsh(b, 1)) Next: End With Rem Add New Workbook Set wbk = Workbooks.Add With wbk Rem Delete All Worksheets but One Application.DisplayAlerts = False For Each wsh In .Worksheets With wsh If .Index = 1 Then .Name = "!DELETE" Else .Delete End With: Next Application.DisplayAlerts = True Rem Copy Worksheets For Each vItm In aWshSrc vItm.Copy After:=Sheets(.Sheets.Count) Set wsh = .Sheets(.Sheets.Count) wsh.UsedRange.Value = wsh.UsedRange.Value2 Next Rem Delete Reamining Worksheet Application.DisplayAlerts = False .Worksheets("!DELETE").Delete Application.DisplayAlerts = True End With End Sub

أحسنت استاذ خلف جزاك الله كل خير

بارك الله فيك وزادك الله من فضله

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

تفضل تم وضع كود الأستاذ ابراهيم بملفك وربطه بالزر 111.xlsm

وعليكم السلام-لك ما طلبت 1مرتب.xlsx

وعليكم السلام-تفضل لك ما طلبت طرح تاريخ.xlsm

ان لم يعجبك هذا فيمكنك متابعة هذا الموقع Generating QR Code barcodes from cells in Excel using VBA and Bytescout BarCode SDK