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

تفضل 🙂 تم تعديل النموذج والكود ليشمل جميع كائنات A و P ، التعديلات في مشاركتي السابقة على الحقول A ، تم تنفيذها على الحقول P ، كود الحالي اصبح : Private Sub Form_Current() On Error GoTo err_Form_Current Dim rst As DAO.Recordset Dim i As Integer 'un Select the Selected option buttons For i = 11 To 48 Me("A_" & i) = 0 Me("A_" & i).Visible = True Next i For i = 51 To 85 Me("P_" & i) = 0 Me("P_" & i).Visible = True Next i 'Hide the Removed teeth Set rst = Me.sfrm_All_P.Form.RecordsetClone rst.MoveLast: rst.MoveFirst: RC = rst.RecordCount For i = 1 To RC Select Case rst!Tooth_Number Case 11 To 48 Me("A_" & rst!Tooth_Number).Visible = False Case 51 To 85 Me("P_" & rst!Tooth_Number).Visible = False End Select rst.MoveNext Next i Exit_Form_Current: Exit Sub err_Form_Current: If Err.Number = 3021 Then 'when there is NO Record Resume Exit_Form_Current ElseIf Err.Number = 2465 Then 'the numbers are 11 to 28, then 38 to 48 'so instead of doing another loop, we'll ignor the error Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub . والوحدة النمطية اصبحت : Public Function f_Remove_a_Tooth() Dim frm As String Dim fld As String frm = Screen.ActiveForm.Name fld = Screen.ActiveControl.Name 'add a new Record, and add the Tooth number in to Forms!All_P.SetFocus Forms!All_P!sfrm_All_P.SetFocus DoCmd.GoToRecord , , acNewRec Forms!All_P!sfrm_All_P!DDate = Now() Forms!All_P!sfrm_All_P!Tooth_Number = Replace(Replace(fld, "A_", ""), "P_", "") Forms!All_P!sfrm_All_P!Remarks.SetFocus 'now hide the tooth Forms(frm)(fld).Visible = False End Function جعفر 1188.Dental.accdb.zip

شيت حساب ضريبة كسب العمل وفقا للتعديل المتوقع يوليو2020 حساب الضريبة وفقا للتعديل المتوقع يوليو2020.xls

اخي الفاضل الموضوع مكرر أكثر من مرة ..... كان بامكانك كتابة للرفع فقط ,,,,,,, على كل حال انظر التعديل على الملف ..... ربما هو طلبك .... db1 (2).accdb

رااااااائع استاذ خالد فعلا النتيجة ممتازة وللعلم تعلمت لاول مرة انشاء ماكرو او كود بهذه الطريقة ... بارك الله فيك ...

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم تم انشاء تقرير بع الرصيد التراكمي wesam.rar تحياتي

وعليكم السلام انظر المثال في الرابط التالي ::بالتوفيق::

تفضل اخي book.xlsx

السلام عليكم اخي العزيز كان طلبك (حفظ الملف في اماكن متفرقه في مجلد باسم ثابت ولكن في اكثر من مكان علي الجهاز او الشبكه بدون السؤال ) يعني اسم المجلد ثابت ومكانه ثابت (مسار المجلد ثابت) * اغلب الاقراص الصلبه في اجهزة الحاسوب تتكون من اربعة احرف او سته او اقل من ذلك مثلا (C,D,E,F,G,H) حسب السعة التخزينية له. مثلا لو كان عندك القرص الصلب 1 تيرابايت (1 TB) من البيانات هل من المعقول ان يقوم الاكسس بقحص كل هذه الملفات لايجاد مجلد باسم اوفيسنا حتى يقوم بنسخ قاعدة البيانات فيه هل تعلم كم من الوقت يحتاج لهذه العملية ؟؟؟؟؟؟؟ *رايي من الافضل ان نحدد مسار لحفظ الملف داخل المجلد بالكود حتى لو كان 10 مجلدات قي اماكن مختلفة من الجهاز (C,D,E,F,G,H) تحياتي

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

هممم في هذه الحالة ، خلينا نجمع جميع العمليات مع بعض ، الحشو ، التنظيف ، الخلع ، .... بحيث لما تنقر مرتين على الضرس ، ويعمل البرنامج سجل جديد ، فيجب ان يكون هناك كومبوبوكس يختار الدكتور العمل الذي يقوم به على الضرس (الحشو ، التنظيف ، الخلع) ، وعلى حسب الاختيار (رقم الضرس ونوع العمل على الضرس) نخفي الضرس ، او نجعل لونه ازرق ، تبدأ من آخر سجل وتنتهي بأول سجل 🙂 مخمخها في دماغك ، بحيث يكون عندك في النموذج الفرعي سجل كامل بأسنان الزبون ، وطبعا لاحقا في المستقبل ، اكيد ستزيد حقول النموذج الفرعي ، حتى تتأقلم وطلبات الدكتور 😁 جعفر

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم Private Sub N1_BeforeUpdate(Cancel As Integer) On Error Resume Next If Me.NewRecord = True Then Dim strWhere As String, strMessage As String strWhere = "[B] = '" & Me![N1] & "'" Me.RecordsetClone.MoveFirst Me.RecordsetClone.FindFirst strWhere If Me.RecordsetClone.NoMatch = False Then strMessage = " الصنف مكرر" lResponse = MsgBox(strMessage, vbOKOnly + vbCritical) If lResponse = vbOK Then Cancel = True Me.Undo Me.Bookmark = Me.RecordsetClone.Bookmark End If End If End If End Sub TEST11.rar تحياتي

السلام عليكم بعد اذن استاذنا العزيز @jjafferr انا امس عملت لك تجربه على سن واحد (18) فقط لكنك لم تستخدم الزر next (الذي فيه الكود) انت استخدمت الزر new record (لايوجد فيه كود) المهم وبنقس الطريقة السابقة على كل الاسنان من 11-48 اتمنى يكون المطلوب حسب مافهمت من طلبك اعلمنا النتائج تحياتي test-2.rar

عند اذن يجب استعمال هذا الماكرو Option Explicit Sub ADD_S_with_Hyper() 'code to add Sheets One Time WITH HYPERLINKS 'Crated By Salim Hasbaya On 17/03/2020 Dim rg As Range, Rg_copy As Range Dim Title_rg As Range, Past_rg As Range Dim S As Worksheet Dim LB%, K%, i% Dim x Dim ws As Worksheet Set S = Sheets("Salim") Set Title_rg = S.Range("a6").Resize(2, 67) Application.ScreenUpdating = False LB = S.Cells(Rows.Count, 2).End(3).Row For Each rg In S.Range("B8:B" & LB) If rg.Value <> "" Then If Not Application.Evaluate("ISREF('" & rg.Value & "'!A1)") Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = rg.Value With ActiveSheet .Hyperlinks.Add Anchor:=.Range("D1"), Address:="", SubAddress:= _ "SALIM!B2", TextToDisplay:="Goto SALIM" .Cells(1, 2) = rg .Columns("A:A").AutoFit .Columns("D:D").AutoFit End With End If End If Next rg With Sheets("Salim") .Hyperlinks.Delete For i = 8 To LB x = Application.CountIf(S.Range("B2:B" & i), S.Range("B" & i)) If x = 1 Then .Hyperlinks.Add Anchor:=.Range("B" & i), Address:="", SubAddress:= _ "'" & .Range("B" & i) & "'!B1", TextToDisplay:=.Range("B" & i).Value S.Range("B" & i).Font.Underline = False S.Range("B" & i).Font.Size = 16 Else S.Range("B" & i).Font.Underline = False S.Range("B" & i).Font.Size = 16 End If Next .Select With S.Range("b8:b" & LB) .HorizontalAlignment = 1: .Font.ColorIndex = 1 .Font.Bold = -1: .InsertIndent 1 .Borders.LineStyle = 1 End With For i = 8 To LB Set ws = Sheets(S.Range("B" & i) & "") Title_rg.Copy ws.Range("a6").PasteSpecial Set Rg_copy = S.Range("A" & i) Set Past_rg = ws.Range("A8") Call give_data(Rg_copy, Past_rg, 67) Application.CutCopyMode = False Next Application.ScreenUpdating = True End With End Sub '++++++++++++++++++++++++++++++++ Sub give_data(S_rg As Range, Target_rg As Range, n As Integer) S_rg.Resize(, n).Copy Target_rg.PasteSpecial Target_rg.Offset(, 1).Resize(, n - 1).Columns.AutoFit End Sub الملف من جديد ISHAAR_2.xlsm

اخي الكريم جرب المرفق خطا في كود حد الصفحة (1).xls

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

السلام عليكم ورحمة الله وبركاته ***** لا تستخدم هاتفك الشخصي ، فالبرنامج سيحذف جميع الصور التي في المجلد sdcard/DCIM/Camera ***** هذا جزء رقم 1 من مشروع متكامل لتصوير الاشخاص والمستندات بإستخدام الكاميرات والماسح الضوئي (Scanner) ، والمشروع يتكون من: يعني مو بس البرامج الكبيرة تستخدم هذه التقنيات ، وإحنا بعد وهذه الاجهزة ستكون لتصوير الاشخاص والمستندات ، ان شاء الله التصوير عن طريق كاميرا هاتف اندرويد ، وتمت التجربة على هاتف اندرويد Galaxy S3 بنظام 4.4 و Huawei Mate 7 بنظام اندرويد 6 ، التصوير عن طريق WebCam ، وتمت التجربة على Logitec HD c615 ، التصوير عن طريق الكامرات الكبيرة من نوع DSLR ، وتمت التجربة على Nikon D5100 او Canon Mark iii ، تطويع الماسح الضوئي لتصوير المستند/المستندات ، وحفظ المستندات الى اي مجلد ، بصيغة pdf او jpg العمل غير مكتمل 100% ، والخطوات التي على قائمة العمل: 1. إعطاء المستخدم الآلية لتحديد مكان قطع الصورة (لمرة واحدة طبعا) ، وحذف الزوائد ، مثلا: الخلفية الثابته: . تصوير الشخص . قطع الصورة وحذف الزوائد (برمجيا) . وكذلك يمكن الاستفادة منه في تصوير مستندات A4 او A5 ، وقطع الصورة وحذف الزوائد (طبعا يكون هناك زر للـ A4 وزر آخر للـ A5) 2. ماذا لو اردت حفظ صورة / مستند ، وكانت هناك صورة سابقا بنفس الاسم؟ سيكون للمستخدم 3 اختيارات: أ- احذف الصورة القديمة واستبدلها بالصورة الجديدة ، ب- اعطي الصورة الجديدة الرقم التسلسلي التالي ، حسب آخر رقم موجود للصورة ، مثلا: الصورة الموجودة سابقا 1.jpg او Inward_2017_05_06.jpg والصورة الجديدة ستصبح 1_001.jpg او Inward_2017_05_06_001.jpg هذه العملية تنفع للأرشفة ج- دائما اجعل الصورة الجديدة بدون ترتيب ، واجعل الصورة السابقة تأخذ آخر رقم ، مثلا الصورة الموجودة سابقا 1.jpg او Inward_2017_05_06.jpg وآخر صورة في المجلد لنفس الصورة هي 1_001.jpg او Inward_2017_05_06_001.jpg عليه سنأخذ آخر صورة موجودة في المجلد ونعطيها الرقم التسلسلي التالي 1_002.jpg او Inward_2017_05_06_002.jpg والصورة الجديدة التي سنلتقطها ستكون 1.jpg او Inward_2017_05_06.jpg هذه العملية تنفع لبرامجنا والتي تستعمل اسم الصورة ، والذي يكون رقم الموظف مثلا وبقية الصور تسلسلها حسب القِدم . 3- حفظ الصور افقيا او عموديا. والآن الى برنامجنا التصوير عن طريق كاميرا هاتف اندرويد اولا: تهيئة الهاتف (البرنامج المرفق فيه المادة رقم2 ، ولا يوجد داعي لإنزاله) : رجاء اتباع الخطوات التالية ليكون الهاتف مهيأ للإتصال بالبرنامج ، ويجب ان يكون الهاتف موصل بالكمبيوتر عن طريق USB: 1- يجب ان يكون الكمبيوتر متعرف على هاتفك ، ويمكنك انزال هذا التعريف من شركة هاتفك ، او من الرابط التالي ، رقم 1 : http://adbshell.com/downloads . وبرنامجنا محتاج الى البرنامج الذي في الرابط اعلاه ، رقم 2 ، والذي لا يحتاج الى تنصيب (ونضع محتواه في المجلد Android_Mobile كما في الصور في الاسفل) ، او اذا اردت البرنامج اعلاه من مصدر آخر وبه SDK الاندرويد (اي جميع برامج التحكم في جزئياته) ، فيمكن تنزيله من الرابط: https://dl.google.com/android/repository/platform-tools-latest-windows.zip 2- يجب ان يكون هاتفك في وضع Developer Options ، كما في الصورة: . واذا لم يكن ، فعليك اتباع الخطوات التالية لعمله : من الاعدادات . وسترى . ثم انقر على المربع الاحمر ، ليأخذك الى الصورة التاليه ، واختار المربعين بعلامة صح . وعند ربط الهاتف بالكمبيوتر ، اختار من الهاتف . وعند تشغيل البرنامج ، سيطلب منك الهاتف الموافقه على السماح بالكمبيوتر التحكم فيه ، فاختار السماح ، 1 ثم 2 . الآن هاتفك مهيأ للتحكم فيه من خلال البرنامج ، ورجاء اجعل الهاتف في وضع الاغلاق (حيث تكون الشاشة سوداء) ، 3- مجلد برنامجك يجب ان يكون بهذه الطريقة . البرنامج مفتوح المصدر ، وتحتاج لمسك مفتاح Shift عند النقر المزدوج على ايقونة البرنامج لفتحه ورؤية الكود ، - البرنامج يفتح على النموذج frm_Main حيث تختار اسم الشخص او رقمه ، . وعند النقر على تفاصيل الموظف او تفاصيل الموظفين ، يفتح النموذج frm_Names ، وتلقائيا سترى ان الهاتف اشتغل ، وعند الخروج من النموذج سوف يغلق الهاتف ، في النموذج frm_Names ، عند النقر على هذه الايقونة سيتم التصوير . وخلال 8-9 ثوان ، سترى الصورة داخل النموذج ، ان شاء الله ويمكنك جعل الهاتف يأخذ الصورة بالفلاش ، من اعدادات الهاتف نفسه ، هذا كود البرنامج بطريقين ، الطريقة الاولى والتي تأخذ الوقت الاقل ، وتركت الطريقة الثانيه الابسط هنا كذلك للذي يريد اللعب فيه وتغييره: Private Sub Form_Load() Call BE_or_FE 'Adb location App_Location = BE_Path & "Camera_App\Android_Mobile\Adb.exe" 'turn on the Device cmmd = " shell input keyevent KEYCODE_POWER" Call Shell(App_Location & cmmd, vbHidden) End Sub Private Sub Form_Close() Call BE_or_FE 'Adb location App_Location = BE_Path & "Camera_App\Android_Mobile\Adb.exe" 'turn off the Device cmmd = " shell input keyevent KEYCODE_POWER" Call Shell(App_Location & cmmd, vbHidden) End Sub Private Sub cmd_Android_Camera_Click() On Error GoTo err_cmd_Android_Camera_Click 'KEYCODE_POWER = 26 'KEYCODE_CAMERA = 27 'KEYCODE_BACK = 4 'KEYCODE_HOME = 3 Dim cmmd As String 'how long does it take to take the picture istart = Timer 'set BE_Path Call BE_or_FE 'Adb location App_Location = BE_Path & "Camera_App\Android_Mobile\Adb.exe" Save_images_to = BE_Path & "images\" 'image capture mode cmmd1 = App_Location & " shell " & Chr(34) & "am start -a android.media.action.STILL_IMAGE_CAMERA" & "; sleep 1; " cmmd2 = "input keyevent KEYCODE_CAMERA" & "; sleep 2; " cmmd3 = "input keyevent KEYCODE_BACK" & ";" & Chr(34) cmmd = cmmd1 & cmmd2 & cmmd3 'Debug.Print cmmd Call ShellWait(cmmd, vbHidden) 'transfer the image to the PC cmmd = App_Location & " pull /sdcard/DCIM/Camera/ " & Save_images_to & "temp\" Call Shell(cmmd, vbHidden) 'Delete the pictures from the mobile camera folder cmmd = App_Location & " shell rm /sdcard/DCIM/Camera/*.jpg" Call Shell(cmmd, vbHidden) PauseTime = 1 Start = Timer Do While Timer < Start + PauseTime DoEvents Loop 'Delete the existing Employee_ID Kill Save_images_to & Me.Employee_ID & ".jpg" 'move the picture from folder temp and change its name Dim StrFile As String StrFile = Dir(Save_images_to & "temp\") Do While Len(StrFile) > 0 Mobile_Pic = StrFile StrFile = Dir Loop Name Save_images_to & "temp\" & Mobile_Pic As Save_images_to & Me.Employee_ID & ".jpg" PauseTime = 1 Start = Timer Do While Timer < Start + PauseTime DoEvents Loop 'show the picture in the Form Me.Pic.Picture = Save_images_to & Me.Employee_ID & ".jpg" 'Delete the temp folder RmDir Save_images_to & "temp\" 'MsgBox Timer - istart Exit Sub to_Here: 'image capture mode cmmd = " shell " & Chr(34) & "am start -a android.media.action.STILL_IMAGE_CAMERA" & Chr(34) Call ShellWait(App_Location & cmmd, vbHidden) 'Dim PauseTime, Start PauseTime = 1 Start = Timer Do While Timer < Start + PauseTime DoEvents Loop 'take a picture cmmd = " shell " & Chr(34) & "input keyevent KEYCODE_CAMERA" & Chr(34) Call ShellWait(App_Location & cmmd, vbHidden) PauseTime = 1 Start = Timer Do While Timer < Start + PauseTime DoEvents Loop 'exit the image capture mod cmmd = " shell " & Chr(34) & "input keyevent KEYCODE_BACK" & Chr(34) Call ShellWait(App_Location & cmmd, vbHidden) Call ShellWait(App_Location & cmmd, vbHidden) PauseTime = 1 Start = Timer Do While Timer < Start + PauseTime DoEvents Loop 'transfer the image to then PC cmmd = " pull /sdcard/DCIM/Camera/ " & Save_images_to & "\temp" Call ShellWait(App_Location & cmmd, vbHidden) PauseTime = 1 Start = Timer Do While Timer < Start + PauseTime DoEvents Loop 'Delete the image from the camera cmmd = " shell rm /sdcard/DCIM/Camera/*.jpg" Call Shell(App_Location & cmmd, vbHidden) PauseTime = 1 Start = Timer Do While Timer < Start + PauseTime DoEvents Loop 'Delete the existing Employee_ID Kill Save_images_to & Me.Employee_ID & ".jpg" 'move the picture from folder temp and change its name 'Dim StrFile As String StrFile = Dir(Save_images_to & "temp\") Do While Len(StrFile) > 0 Mobile_Pic = StrFile StrFile = Dir Loop Name Save_images_to & "temp\" & Mobile_Pic As Save_images_to & Me.Employee_ID & ".jpg" PauseTime = 1 Start = Timer Do While Timer < Start + PauseTime DoEvents Loop 'Delete the temp folder RmDir Save_images_to & "temp\" 'show the picture in the Form Me.Pic.Picture = Save_images_to & Me.Employee_ID & ".jpg" 'MsgBox Timer - istart Exit_cmd_Android_Camera_Click: Exit Sub err_cmd_Android_Camera_Click: If Err.Number = 53 Then 'No picture to delete Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub والبرنامج حاليا للمتطوعين الذين يعرفون ان البرنامج لا يحتوي على اي ميزات غير التصوير وحفظ الصور في المجلد Images ، وربط الصور برقم الموظف ورجاء اخبرونا عن نتائج تجربتكم وملاحظة هامة: ***** لا تستخدم هاتفك الشخصي ، فالبرنامج سيحذف جميع الصور التي في المجلد sdcard/DCIM/Camera ***** جعفر Camera_Scanner.zip

فورم التنقل بين الشيتات مع البحث والاضافة والتعديل والحذف الفيديو

كان من الواجب عليك حفظ الملكية الفكرية التي هي من اساسيات هذا المنتدى و اعلان اسم من وضع لك الكود في الملف ربما كان الحل في الشيت Repport من هذا الملف Saerch_by_column.xlsm

كيف بيعلق ؟ ارفق لك نفس الملف مضغوط وملف اخر بالتوفيق ان شاء الله تنبيه_برسالة_فى_التواريخ.rar رسالة على انتهاء ميعاد.rar

بالتوفيق اخي الكريم والشكر موصول لأستاذنا جعفر😍😍

اخي الحل بسيط جدا 1- اقتح الماكرو 2- امسح الذي بداخل الحقل عند اسم النموذج 3- اختر اسم النموذج المراد فتحه من القائمة 4- احفظ تحياتي

تفضل عدد الشهور المستحقة حتى الان.xls

يمكنك مشاهدة هذا الفيديو https://www.youtube.com/watch?v=CpR8QvC6pAA

استاذى الفاضل jjafferr بعدالتحية وخالص الشكر على الرد وسعة صدرك واحتمالك لجهلى بالمقارن بخبرتك عندما ارفقت القاعدة فى المرة الاولى كنت رابط الاسنان بجدول teeth وعندالضغط على الضرس يظهر امام رقم الضرس فى الجدول -1 وبالتالى يظل محدد فى النموذج الا توجد طريقة نضم طريقة حضرتك الرائعة فى خلع الاسنان وطريقتى المتواضعة فى تحديد الضروس وبكدة اكون قد حصلت علة ضالتى المنشودة خالص الشكر والتقدير

موفق دائماً اخي الكريم تحياتي

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

تصحيح بسيط With sh.Range("B7").Resize(m - 7, 13) .Borders.LineStyle = 1 .HorizontalAlignment = 1 .InsertIndent 1 With .Font .Bold = True .Size = 14 End With '++++++++++++++++++++++++++++++++++++++++++++++++++++++ ' الرقم 10 هنا يرمز الى رقم العامود في الجدول حيث يوجد التاريخ 'أقصد العمود K .Columns(10).NumberFormat = "yyyy/m/d" '+++++++++++++++++++++++++++++++++++++++++++++++++++++++ End With End Sub

تابع هذا الفيديو حل مشكلة فشل Microsoft Access من إنشاء الوحدة النمطية Visual Basic

أضف هذا العبارة في نهاية الكود قبل End With الأخيرة .Value = .Value لتصبح نهاية الكود هكذا With sh.Range("B7").Resize(m - 7, 13) .Borders.LineStyle = 1 .HorizontalAlignment = 1 .InsertIndent 1 With .Font .Bold = True .Size = 14 End With .Value = .Value End With End Sub

الخطأ مطبعي في الــ Dim يجب كتابة $targt و ليس &targt Dim myArray, arr(11), targt$

شكرا لكم على سرعة الاجابة وفقكم الله ودائما مبدع استاذ سليم عند تنفيذ الكود ظهر خطا لا في السطر الاصفر لكم وافر احترامي وتقديري

هذا الماكرو يقوم بما تريد Option Explicit Option Base 1 Sub My_code() Dim m%, k%, lr%, i% Dim Main As Worksheet, sh As Worksheet Dim myArray, arr(11), targt$ Set Main = Sheets("Allstudents") Set sh = Sheets("from.school") sh.Range("B7:M1000").Clear targt = "from*" lr = Main.Cells(Rows.Count, "D").End(xlUp).Row m = 7 For i = 3 To 13 arr(i - 2) = i Next myArray = Array(38, 4, 5, 27, 13, 16, 18, 19, 20, 21, 22) For i = 5 To lr If Main.Cells(i, "AD") Like "*" & targt Then For k = 1 To 11 sh.Cells(m, arr(k)) = Main.Cells(i, myArray(k)) Next m = m + 1 End If Next With sh.Range("B7").Resize(m - 7, 13) .Borders.LineStyle = 1 .HorizontalAlignment = 1 .InsertIndent 1 With .Font .Bold = True .Size = 14 End With End With End Sub الملف مرفق My_data .xlsm

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

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

ولم الاسف اخى كلنا اخوه فالله وانا اخوكم الصغير اتعلم منكم ومعكم جزاك الله خيرا

تمام شكرا عزيزي

بغير فارزه . وبغير فواصل . جعفر

يجب ان يكون العامود الثاني(B) فارغاً وايضاً الصف الثالث(ٌRow 3) كي يعرف الاكسل اي مجموعة يجب اخذها كي يمسح القديم منها ويسجل الجديد الملف من جديد Distribution_new.xlsm

بعد اذن استاذ طارق المرفقات ...مع ملاحظة 1- ضع الملفات الفرعية في مجلد باسم MyFolder في القسم c 2- ضع الملف الرئيسي 00.xlsm في اي مكان ترغب فيه بشرط ان لايكون داخل المجلد ضمن الملفات الفرعية 3- يمكن لك تغير مسار الملفات الفرعية دخل المجلد في هذا السطر داخل علامتي "" Folderpath = "C:\MyFolder\" 00.xlsm 01.xlsx 02.xlsx 03 .xlsx

السلام عليكم أخي الكريم ممكن تراجع هذا الموضوع قد يكون هو ماتريد

أخواني كما هو في السؤال هل من كود يوقف عمل البرنامج بعد زمن معين؟؟

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

اظن حضرتك تبحث عن هذا الموظوع لاستاذنا الكبير جعفر

شكرا اخي ولكن المعلومة هذه غير متكاملة وغير دقيقة ، فلو تابعت المشاركات في الرابط الذي ارفقته انت ، سترى ان العضو Kamali_82 استعمل الكود ولم يعمل معه ، كما وانه لي مشاركة في نفس الموضوع واشرت فيه الى رابط موضوع آخر يحل المشكلة. وهذا رابط يناقش نفس الموضوع جعفر

شكرا أخي ياسر بعد محاولات عديدة وتتبع للخلل وجدت بغيتي أنا كنت أبحث عن كلمات وأرقام وكان الخطأ عند البحث بواسطة كلمة ، ولكن بعد حذف "cdb1 " من السطر حلت المشكلة وتم تعديل السطر الى If (.Cells(I, (Range("b1").Value))) = (Range("C1")) Then مرفق ملف لمن أراد الاستزادة Overtime Report Loop Through All Sheets YasserKhalil 1.rar وطلب أخير هل يمكن اختصار الكود من الأسطر والمتغيرات الغير ضرورية لملفي - ان وجدت - لسهولة التعديل بعد ذلك ؟؟