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

جرب الكود بهذا الشكل Sub ClearSheet() On Error Resume Next Range("A8:BT" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants).ClearContents End Sub تقبل تحياتي

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

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

أخي العزيز سعيد بيرم وعليكم السلام ورحمة الله وبركاته الحمد لله أن تم المطلوب الأول على خير .. وإن كنت أفضل التعامل مع الطلبات كل طلب في موضوع منفصل ، لكني سأقوم بعمل استثناء لك ..!! رغم أنه ليس من المفضل لدي العمل على أكثر من طلب في موضوع واحد إليك الكود التالي عله يكون المطلوب تم استخدام طريقة أخرى أفضل من الحلقات التكرارية لأنها تتناسب أكثر مع طلبك وهي طريقة الفلترة .. حيث تم فلترة البيانات على أساس عمود الكمية والإبقاء على الكميات المرصودة فقط أما الخلايا الفارغة للكميات فيتم فلترتها وتظهر الصفوف المطلوبة فقط ، وعلى أثر ذلك يتم نسخ البيانات الظاهرة فقط ووضعها في الورقة المراد الترحيل إليها إليك الكود Sub TransferDataUsingFilterMethod() Dim WS As Worksheet, SH As Worksheet Dim LR As Long, LastRow As Long Dim X As Long, I As Long Set WS = Sheet1: Set SH = Sheet5 LR = WS.Cells(Rows.Count, 1).End(xlUp).Row LastRow = SH.Cells(Rows.Count, "D").End(xlUp).Row + 1 Application.ScreenUpdating = False With WS .AutoFilterMode = False .Range("A7:D7").AutoFilter Field:=3, Criteria1:="<>" & "" .Range("B8:D" & LR).SpecialCells(xlCellTypeVisible).Copy SH.Cells(LastRow, "D").PasteSpecial xlPasteValues SH.Cells(LastRow, "B").Value = WS.Range("B6").Value SH.Cells(LastRow, "C").Value = WS.Range("C3").Value .AutoFilterMode = False End With Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Done...", vbInformation, "YasserKhalil" End Sub تقبل تحياتي

أخي الكريم مدحت الموضوع من 15 يوم ولسه فاكر تتابعه ... عموماً الملف بحاجة إلى مزيد من التفاصيل .. ما هي القائمة التي تستخرج منها أسماء العملاء .. ويرجى تحديد الطلب بذكر ورقة الترحيل المراد الترحيل منها وورقة الترحيل المراد الترحيل إليها وما هي الخلايا أو النطاقات التي تريد ترحيلها .. أي أن الموضوع يحتاج لتفصيل .. لا تدع الأخوة الأعضاء يخمنون المطلوب بل كن واضح ودقيق في طلبك أرجو ألا تكون منزعج من كلامي تقبل تحياتي

جرب هذا الملف كنموذج بعد تشغيل الماكرو بواسطة الزر اضغط على اسم اي ملف لفتحه listfiles 1.rar

أخي الكريم عبد العزيز المدني جرب الكود بهذا الشكل ليتناسب مع ملفك المرفق Sub TestRun() Dim I As Long For I = 8 To Cells(Rows.Count, "B").End(xlUp).Row If Kh_Names(Cells(I, "B"), 1) = Cells(I, "B") Then Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) ElseIf Kh_Names(Cells(I, "B"), 1, 2) = Cells(I, "B") Then Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) Cells(I, "I") = Kh_Names(Cells(I, "B"), 2) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3) = Cells(I, "B") Then Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) Cells(I, "F") = Kh_Names(Cells(I, "B"), 2) Cells(I, "I") = Kh_Names(Cells(I, "B"), 3) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4) = Cells(I, "B") Then Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) Cells(I, "F") = Kh_Names(Cells(I, "B"), 2) Cells(I, "G") = Kh_Names(Cells(I, "B"), 3) Cells(I, "I") = Kh_Names(Cells(I, "B"), 4) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4, 5) = Cells(I, "B") Then Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) Cells(I, "F") = Kh_Names(Cells(I, "B"), 2) Cells(I, "G") = Kh_Names(Cells(I, "B"), 3) Cells(I, "H") = Kh_Names(Cells(I, "B"), 4) Cells(I, "I") = Kh_Names(Cells(I, "B"), 5) Else Cells(I, "E") = Kh_Names(Cells(I, "B"), 1) Cells(I, "F") = Kh_Names(Cells(I, "B"), 2) Cells(I, "G") = Kh_Names(Cells(I, "B"), 3) Cells(I, "H") = Kh_Names(Cells(I, "B"), 4) Cells(I, "I") = Kh_Names(Cells(I, "B"), 5) End If Next I End Sub Function Kh_Names(FullName As String, ParamArray Index1()) As String Dim I As Integer Dim Kh_Split, MyArray, Arr Dim Kh_String As String, SN As String, RE As String On Error GoTo Err_Kh_Names MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله", "زين ") SN = Application.WorksheetFunction.Trim(FullName) For Each Arr In MyArray RE = Replace(Arr, " ", "^") SN = Replace(SN, Arr, RE) Next Kh_Split = Split(SN, " ", , vbTextCompare) On Error Resume Next For I = 0 To UBound(Index1) Kh_String = Kh_String & " " & Kh_Split(Index1(I) - 1) Next On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") Kh_Names = Kh_String Exit Function Err_Kh_Names: Kh_Names = "" End Function بالنسبة لنتائج الكود لن تكون صحيحة بسبب سوء البيانات المدخلة فمثلا الاسم ناصرسعدناصرمحمدالغيلي لا توجد أية مسافات في الاسم من ثم سيعامله الكود على أنه اسم واحد ويتم وضع كامل الاسم في خلية الاسم فقط يوجد مسافات كثيرة في الأسماء .. مثل صا لح (قم بإزالة مثل هذه المسافات) - هشا م - منا ل ... ويوجد أسماء كثيرة بهذا الشكل إذا أردت أن تحصل على نتائج صحيحة فلابد أن تكون المدخلات صحيحة تقبل تحياتي

أخي الغالي سعيد يبدو أنني قد فهمت المطلوب بعد الإمعان في الملف المرفق إليك الكود التالي عله يكون المطلوب ... رغم أنني لا أحبذ العمل على الاحتمالات بس إن شاء الله يكون المطلوب Sub TransferMatchingData() Dim WS As Worksheet, SH As Worksheet Dim Cel As Range, Found As Range Set WS = Sheet1: Set SH = Sheet3 Application.ScreenUpdating = False On Error Resume Next For Each Cel In WS.Range("B8:B" & WS.Cells(Rows.Count, "B").End(xlUp).Row) Set Found = SH.Range("B:B").Find(What:=Cel.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) If Not Found Is Nothing And Not IsEmpty(Cel.Value) Then Found.Offset(, 1).Resize(1, 2).Value = Cel.Offset(, 1).Resize(1, 2).Value End If Next Cel Application.ScreenUpdating = True End Sub تقبل تحياتي

السلام عليكم ورحمة الله وبركاته ... فيه سؤال للأخ الرهوي في الرابط التالي يسأل عن البحث داخل مربع التحرير والسرد نفسه بمجرد الكتابة http://www.officena.net/ib/topic/66565-كيف-ابحث-في-مربع-سرد-بجزء-من-الكلمة-؟/ بحثت وحاولت ولم افلح ... وبعد بحث طويل وجدت المطلوب .. في الحقيقة لا اعلم ان كان هناك طرق اخرى ... ولكن بالنسبة لي لم اجد الا هذه الطريقة القوا نظرة على المرفق ان شاء الله يفيدكم .. هذا رابط المرجع ... http://www.tek-tips.com/faqs.cfm?fid=6295 وهذا الكود الأساسي مع الشرح قبل التعديل Private Sub Combo0_Change() ' Function Description: ' Filter a combo box list as the user types, similarly to how application ' launchers like Colibri, AppRocket and LaunchBar opperate. ' e.g. if the list contains the names of U.S. Presidents, and ' the user types "gw," then the resulting SQL WHERE clause will ' look like "Name Like '*g*w*'" and the resulting list ' will include George Washington, George H. W. Bush and ' George W. Bush, among others. ' The order is preserved, so that typing "wg" creates an SQL WHERE ' clause like "Name Like '*w*g*'" and the resulting list would ' include George Washington but not the Bushes. ' This is accomplished by grabbing the text typed by the user in the ' combo box's edit field, creating an SQL SELECT statement from it, ' and finally applying that SQL statement to the combo box's ' .RowSource property. ' Form design settings: ' Set AutoExpand to No ' Column Count 3 ' Keyed on column 1 (record primary key) ' Showing column 2 (user-readable data) column 2 width > 0 ' First and Second column width=0 Dim strText, strFind ' Get the text that the user has typed into the combo box editable field. strText = Me.Combo0.Text ' If the user has typed something in, then filter the combobox ' list to limit the visible records to those that contain the ' typed letters. ' Otherwise (if the field is blank), the user has deleted whatever ' text they typed, so show the entire (unfiltered) list If Len(Trim(strText)) > 0 Then ' Show the list with only those items containing the typed ' letters. ' Create an SQL query string for the WHERE clause of the SQL ' SELECT statement. strFind = "Name Like '" For i = 1 To Len(Trim(strText)) If (Right(strFind, 1) = "*") Then ' When adding another character, remove the ' previous "*," otherwise you end up with ' "*g**w*" instead of "*g*w*." ' This has no apparent impact on the user, but ' ensures that the SQL looks as intended. strFind = Left(strFind, Len(strFind) - 1) End If strFind = strFind & "*" & Mid(strText, i, 1) & "*" Next strFind = strFind & "'" ' Create the full SQL SELECt string for the combo box's ' .RowSource property. strSQL = "SELECT tName.nameKey, tName.Name, SortOrder FROM tName Where " & _ strFind & " ORDER BY SortOrder;" '' NOTE: to remove the order requirement, such that typing "wg" '' and "gw" return the same results, the SQL WHERE clause needs '' to look like "Name Like '*w* AND *g*'." '' The code above should be changed as follows: ''For i = 1 To Len(Trim(strText)) '' strFind = strFind & "Name Like '*" & Mid(strText, i, 1) & "*' And " ''Next '' ''strSQL = "SELECT tName.nameKey, tName.Name, SortOrder from tblApps Where " & _ ''Left(strFind, Len(strFind) - 5) & " Order By SortOrder" ' Filter the combo list records using the new SQL statement. Me.Combo0.RowSource = strSQL Else ' Show the entire list. strSQL = "SELECT tName.nameKey, tName.Name, tName.SortOrder FROM tName ORDER BY tName.SortOrder; " Me.Combo0.RowSource = strSQL End If ' Make sure the combobox is open so the user ' can see the items available on list. Me.Combo0.Dropdown End Sub اتمنى من خبرائنا واعضاء المنتدى الكرام القاء نظرة على المرفق وعلى الكود كامل لو فيه اضافات او تعديلات . وبالتوفيق للجميع . Search_inside_Combo.rar

. نعم ، ولكن ما ادري اذا تستطيع عمله او لا 1. اذا كان برنامجك accdb مثلا ، تأكد ان النموذج الرئيسي يتم فتحه تلقائيا عند فتح البرنامج ، 2. غيّر اسم الملف من accdb الى accdr ، وبهذه الطريقة يكون الملف مُقفل اتحداك انك تقدر تعملها جعفر

حياك الله يجب ان يكون مفتوح اخي .. اجعله مفتوح ولكن مخفي بالطريقة هذي Private Sub F2_Click() DoCmd.OpenForm "main2", , , , , acHidden If Me.F2 = -1 Then Forms!main2!c2.Visible = True ElseIf Me.F2 = 0 Then Forms!main2!c2.Visible = False End If End Sub بالنسبة لسؤالك الثاني لا يمكن للنموذج ان يحتفظ بها الا اذا كانت احد القيمتين ونجعلها قيمة افتراضية.... ولكن بإمكانك ان تجعلها تأخذ القيمة من الجدول بأي طريقة .. اي تأخذ آخر قيمة في الجدول . بالتوفيق

حياك الله اخي محمد .. هل جربت اخي محمد ؟؟ بالتوفيق

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

اصل الشيت التقرير زى ما فى المرفق عند حضرتك فى جدول واحد

أخي الحبيب عبد العزيز قلم الإكسيل بارك الله فيك وجزاك الله كل خير على كلماتك الرقيقة في حقي وما أنا في النهاية إلا كقطرة في منتدى أوفيسنا منتدى العمالقة أما اقتراحك فأنا خايف الناس تقراه بمسافة بعد الألف ..فبدل ياسل هيقروها يا سل (وكدا أنا هزعل أكيد يا عربي) تقبل تحياتي

حياك الله اخي الكريم هذا مثال على مجموع الحضور للصف الأول بتاريخ اليوم الق نظرة على النموذج frm1 وفي حدث عند التحميل Me.ATTend1 = Nz(DCount("id", "q1", "D = date() And cclass = '" & 1 & "'"), 0) شاهد التعديل في الجدول والاستعلام استبدل التسميات في الكود بما تريد وقم بتغييرها بعد الإستبدال .. بالتوفيق تفقد الطلاب.rar

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

اخي الغالي كل ما عليك هو تعديل المعادلات الى النطاق الذي تريده ستجد معظم المعادلات اخرها 379 عدلها كما تريد وتفضل بعد التعديل CERTIFICAT5.rar

اخ الغالي كان امامي هذا الكود فوضعته لك بدلا من المعادلات اضافة قائمة منسدلة.rar

اطلع على هذا الملف ربما يفيدك .. Protect Formulas Only.rar

جرب هذا الملف (انظر الى الورقة Sheet1) يمكن ان تبني عليه في ملفك الخاص INDEX WITH FILTER SALIM.rar

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

اخواني الكرام حياكم الله جميعا اسمحوا لي اشارك معكم في هذه النقطة هذا الكود يلغي عمل الشفت فعلا ... ولكن هناك برامج خارجية تقوم بتمكين الشفت . (مرفق مثال ) انا جربت المرفق على كل النسخ ويفتحها جميعا .. انا استخدم اكسس 2007 .... الحل الذي اعرفه انا من هذه الناحية هو تغيير الامتداد من accde الى accdr انا استخدم هذا البرنامج Access 2007 Developer Extensions هو برنامج للتحزيم عموما . ومعه يتغير امتداد الملف . .. عند تحميله اضغط على قائمة office من على يمين برنامج الأكسس ستجده في القائمة . بالتوفيق للجميع . sh.rar

حياك الله اخي كرار مشاركة مع استاذنا جعفر تأكد هل هذه المكتبة موجودة في برنامجك الذي تطبق فيه الكود Microsoft DAO object library بالتويق

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

اخى الحبيب الغالى جدا جدا // ابو البراء السلام عليكم ورحمته الله وبركاته والحمد لله تعالى تم المطلوب الثانى على خير بارك الله فيك والله العظيم انا مش عارف من غيرك كنت عملت ايه أطمع فى إستثنائين فقط ويكتمل الموضوع منها تعديلا فى كود واضافة كود أخر وإن لم يكن فسيتم رفع موضوع بهما مساءا إن قدرالله تعالى لى البقاء الله أسأل أن يعطيك ويعطينا بقدرنياتنا الخالصة لوجه الله الكريم وافر تقديرى واحترامى حبيب قلبى **** وجزاكم الله خيرا

أي روابط تقصد ..لم أرى أية روابط بالملف ..؟؟ هل هناك ارتباط تشعبي في مكانٍ ما ...؟

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

ماشاء الله استاذي ياسر خليل

السلام عليكم ورحمة الله اخي الحبيب الفاضل الاستاذ ياسر كوع يسيط مختصر الطرق الطويله التي تؤدي إلي روما (الله يذكره بكل خير الااستاذ احمد إبن مصر ) وشرح رائع سيكون في متناول المبتدئين والمتقدمين جزاك الله خير

ان شاء الله اخي الفاضل

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

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

بارك الله فيك وجزاك الله خيرا ... وجعلها في ميزان حسناتك وبارك الله في علمك .. وأشكرك على النصائح المهمة التي فعلا كنت لا أعلمها والكود عالمي ممتاز بارك الله فيك

أخي الحبيب عبد العزيز المدني عدلت في الكود بشكل كبير بحيث يكون مرن وتستطيع التعديل عليه بكل سهولة كل ما عليك هو التعديل في الأسطر التي تلي التعليقات .. السطر الأول خاص بصف البداية أي أول صف يحتوي على بداية الأسماء والتعديل الثاني هو رقم العمود الموجود فيه الأسماء ..اكتب رقم العمود فإذا كان العمود هو العمود J ستكتب 10 أرجو أن يكون التعديل مناسب لك Sub PopulateFullNamesToAdjacentColumns() Dim I As Long, strName As String 'Row Number Where Names Start Const Row As Long = 2 'Column Number Where Names Exist >> 1 For A - 2 For B - 3 For C ... Const Col As Long = 2 For I = Row To Cells(Rows.Count, Col).End(xlUp).Row strName = Cells(I, Col).Value If Kh_Names(strName, 1) = strName Then Cells(I, Col + 1) = Kh_Names(strName, 1) ElseIf Kh_Names(strName, 1, 2) = strName Then Cells(I, Col + 1) = Kh_Names(strName, 1) Cells(I, Col + 5) = Kh_Names(strName, 2) ElseIf Kh_Names(strName, 1, 2, 3) = strName Then Cells(I, Col + 1) = Kh_Names(strName, 1) Cells(I, Col + 2) = Kh_Names(strName, 2) Cells(I, Col + 5) = Kh_Names(strName, 3) ElseIf Kh_Names(strName, 1, 2, 3, 4) = strName Then Cells(I, Col + 1) = Kh_Names(strName, 1) Cells(I, Col + 2) = Kh_Names(strName, 2) Cells(I, Col + 3) = Kh_Names(strName, 3) Cells(I, Col + 5) = Kh_Names(strName, 4) ElseIf Kh_Names(strName, 1, 2, 3, 4, 5) = strName Then Cells(I, Col + 1) = Kh_Names(strName, 1) Cells(I, Col + 2) = Kh_Names(strName, 2) Cells(I, Col + 3) = Kh_Names(strName, 3) Cells(I, Col + 4) = Kh_Names(strName, 4) Cells(I, Col + 5) = Kh_Names(strName, 5) Else Cells(I, Col + 1) = Kh_Names(strName, 1) Cells(I, Col + 2) = Kh_Names(strName, 2) Cells(I, Col + 3) = Kh_Names(strName, 3) Cells(I, Col + 4) = Kh_Names(strName, 4) Cells(I, Col + 5) = Kh_Names(strName, 5) End If Next I End Sub Function Kh_Names(FullName As String, ParamArray Index1()) As String Dim I As Integer Dim Kh_Split, MyArray, Arr Dim Kh_String As String, SN As String, RE As String On Error GoTo Err_Kh_Names MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله", "زين ") SN = Application.WorksheetFunction.Trim(FullName) For Each Arr In MyArray RE = Replace(Arr, " ", "^") SN = Replace(SN, Arr, RE) Next Kh_Split = Split(SN, " ", , vbTextCompare) On Error Resume Next For I = 0 To UBound(Index1) Kh_String = Kh_String & " " & Kh_Split(Index1(I) - 1) Next On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") Kh_Names = Kh_String Exit Function Err_Kh_Names: Kh_Names = "" End Function تقبل تحياتي Populate Full Names To Adjacent Columns YasserKhalil.rar

نعم اخي الكريم محمد سلامة الكود يقوم بتعطيل زر الشيفت ولكن ما المقصود بالغاء الشيفت نهائي فبعد وضع الوحدة النمطية الشابقة عند استخدام الكود بالشكل التالي يقوم بتعطيل الشيفت SetProperties "AllowBypassKey", DB_BOOLEAN, False والكود بالشكل التالي يقوم بتمكين زر الشيفت SetProperties "AllowBypassKey", DB_BOOLEAN, True تحياتي

الطابعة نفسها ليست عندي ولكني جربت على طاعات اخريات انظر التعديل ان كان يحل شيئا من المسألة Test Barcode2.rar

أخي الكريم أبو إلياس وعليكم السلام ورحمة الله وبركاته باديء ذي بدء أحب أن أنوه إليك أن الملف غير مرضي بالنسبة لي كتنسيق .. لا تقم بتسطير كافة ورقة العمل بدون داعي .. فهذا يجعل الملف ثقيل في التعامل غير أن التسطير في حالتك غير ضروري ..فقط قم بتسطير النطاق المستخدم ... قمت بإزالة التسطير والاكتفاء بجزء من ورقة العمل لسهولة التعامل مع الملف أمر آخر إذا أردت أن ترفق ملف فينصح بوضع بعض البيانات الوهمية للعمل عليها ..قمت بوضع بعض البيانات في ملفك لاختبار النتائج للكود وأخيراً أرجو ألا تنزعج من نصحي ومن كلامي (الذي أراه جارحاً في كثير من الأحيان.. ولكن للضرورة أحكام) إليك الكود التالي يقوم بما تطلب إن شاء الله .. حاول تدرس أسطر الكود لتعرف كيفية التعديل عليه بما يتناسب مع ملفك الأصلي Sub TestYasser() Dim Ws As Worksheet, Sh As Worksheet Dim LR As Long, I As Long, Col As Long, LastRow As Long Set Ws = Sheets("Data"): Set Sh = Sheets("Result") LR = Ws.Cells(Rows.Count, 2).End(xlUp).Row Application.ScreenUpdating = False For I = 10 To LR For Col = 6 To 53 Step 8 LastRow = Sh.Cells(Rows.Count, 2).End(xlUp).Row + 1 Sh.Cells(LastRow, "B").Resize(1, 4).Value = Ws.Cells(I, "B").Resize(1, 4).Value Sh.Cells(LastRow, "F").Resize(1, 8).Value = Ws.Cells(I, Col).Resize(1, 8).Value Next Col Next I Application.ScreenUpdating = True MsgBox "Finished...", 64 End Sub تقبل تحياتي Transfer Data Across Columns To Rows YasserKhalil.rar

بوركت وبورك لك فى أهلك ومالك وجزاك الله عنا خيرا كل الهداية أكسس أكسس .. مفيش مرة كيس جوافة

تم اضافة ازار الطباعة استخدم الازارار لتحديد صفحات الطباعة كشوفات خاصه لتعبئة الشهائد.rar

السلام عليكم محاولة اتمنى ان تكون فيها الافادة استخدم الزر للنتقل بين الصفحات كشوفات خاصه لتعبئة الشهائد.rar

أخي الكريم نايف إليك الكود التالي عله يكون المطلوب Sub Test() 'تعريف المتغيرات Dim Ws As Worksheet, Sh As Worksheet, Cel As Range, LR As Integer 'تعيين قيمة للمتغير ليساوي ورقة العمل المراد الترحيل منها Set Ws = Sheets("mm") 'تعيين قيمة للمتغير ليساوي ورقة العمل المراد الترحيل إليها Set Sh = Sheets("nn") 'تعيين الخلية التي سيتم ترحيل قيمتها Set Cel = Ws.Range("A1") 'تحديد أول خلية فارغة في العمود الأول في الورقة المراد الترحيل إليها LR = Sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 'شرط لاختبار تكرار القيمة باستخدام دالة العد بشرط 'فإذا كان ناتج العد أكبر من أو يساوي 1 ، فذلك يعني أن القيمة موجودة If Application.WorksheetFunction.CountIf(Sh.Columns(1), Cel.Value) >= 1 Then 'طالما أن القيمة موجودة تظهر رسالة تفيد بأن القيمة مكررة MsgBox "القيمة مكررة في العمود", 64 Else 'إذا لم تكن القيمة موجودة من قبل في الورقة المراد الترحيل إليها 'يتم وضع القيمة في أول خلية فارغة في العمود الأول بعد آخر خلية بها بيانات Sh.Range("A" & LR).Value = Cel.Value End If End Sub تقبل تحياتي

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

حياك الله اخي الكريم ... لا أعتقد انك من تختار عدد الجداول والحقول ... بل ان طبيعة العمل وحاجته هي من تقرض عليك عدد الجداول والحقول التي بداخلها .. بالتوفيق

وعليكم السلام لايمكنني الاطلاع على المرفق ولكن كما ذكرت يبدو المشكلة في اعدادات التقرير وقد يكون للطابعة دور انا اطبع باركود واحد لسجل واحد على طابعة عادية A4 ابعاد التقرير = 2.8x1.2 سم

أخي الكريم قلم الإكسيل بارك الله فيك وجزيت خيراً على دعواتك الطيبة المباركة بالنسبة للكود ::: ------------------ أنا مجرب الكود بدل المرة ألف مرة لأني أستخدمه في برامجي الخاصة تأكد من أنك لم تحذف أي شيء من الكود أو الدالة المعرفة .. ضع الكود التالي بالكامل في موديول جديد ثم نفذ الأمر مرة أخرى Sub TestRun() Dim I As Integer For I = 2 To Cells(Rows.Count, "B").End(xlUp).Row If Kh_Names(Cells(I, "B"), 1) = Cells(I, "B") Then Cells(I, "C") = Kh_Names(Cells(I, "B"), 1) ElseIf Kh_Names(Cells(I, "B"), 1, 2) = Cells(I, "B") Then Cells(I, "C") = Kh_Names(Cells(I, "B"), 1) Cells(I, "G") = Kh_Names(Cells(I, "B"), 2) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3) = Cells(I, "B") Then Cells(I, "C") = Kh_Names(Cells(I, "B"), 1) Cells(I, "D") = Kh_Names(Cells(I, "B"), 2) Cells(I, "G") = Kh_Names(Cells(I, "B"), 3) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4) = Cells(I, "B") Then Cells(I, "C") = Kh_Names(Cells(I, "B"), 1) Cells(I, "D") = Kh_Names(Cells(I, "B"), 2) Cells(I, "E") = Kh_Names(Cells(I, "B"), 3) Cells(I, "G") = Kh_Names(Cells(I, "B"), 4) ElseIf Kh_Names(Cells(I, "B"), 1, 2, 3, 4, 5) = Cells(I, "B") Then Cells(I, "C") = Kh_Names(Cells(I, "B"), 1) Cells(I, "D") = Kh_Names(Cells(I, "B"), 2) Cells(I, "E") = Kh_Names(Cells(I, "B"), 3) Cells(I, "F") = Kh_Names(Cells(I, "B"), 4) Cells(I, "G") = Kh_Names(Cells(I, "B"), 5) End If Next I End Sub Function Kh_Names(FullName As String, ParamArray Index1()) As String Dim I As Integer Dim Kh_Split, MyArray, Arr Dim Kh_String As String, SN As String, RE As String On Error GoTo Err_Kh_Names MyArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله", "زين ") SN = Application.WorksheetFunction.Trim(FullName) For Each Arr In MyArray RE = Replace(Arr, " ", "^") SN = Replace(SN, Arr, RE) Next Kh_Split = Split(SN, " ", , vbTextCompare) On Error Resume Next For I = 0 To UBound(Index1) Kh_String = Kh_String & " " & Kh_Split(Index1(I) - 1) Next On Error GoTo 0 Kh_String = Replace(Trim(Kh_String), "^", " ") Kh_Names = Kh_String Exit Function Err_Kh_Names: Kh_Names = "" End Function وهذه صورة من ورقة العمل بعد الضغط على الأمر Run ويمكن التأكد من عمل الكود من الأخوة الكرام الذين جربوا الملف الأخير تقبل تحياتي

لا تَعذَلِيه فَإِنَّ العَذلَ يُولِعُهُ قَد قَلتِ حَقاً وَلَكِن لَيسَ يَسمَعُهُ جاوَزتِ فِي نصحه حَداً أَضَرَّبِهِ مِن حَيثَ قَدرتِ أَنَّ النصح يَنفَعُهُ فَاستَعمِلِي الرِفق فِي تَأِنِيبِهِ بَدَلاً مِن عَذلِهِ فَهُوَ مُضنى القَلبِ مُوجعُهُ قَد كانَ مُضطَلَعاً بِالخَطبِ يَحمِلُهُ فَضُيَّقَت بِخُطُوبِ الدهرِ أَضلُعُهُ يَكفِيهِ مِن لَوعَةِ التَشتِيتِ أَنَّ لَهُ مِنَ النَوى كُلَّ يَومٍ ما يُروعُهُ ما آبَ مِن سَفَرٍ إِلّا وَأَزعَجَهُ رَأيُ إِلى سَفَرٍ بِالعَزمِ يَزمَعُهُ كَأَنَّما هُوَ فِي حِلِّ وَمُرتحلٍ مُوَكَّلٍ بِفَضاءِ اللَهِ يَذرَعُهُ إِذا الزَمانَ أَراهُ في الرَحِيلِ غِنىً وَلَو إِلى السَندّ أَضحى وَهُوَ يُزمَعُهُ تأبى المطامعُ إلا أن تُجَشّمه للرزق كداً وكم ممن يودعُهُ وَما مُجاهَدَةُ الإِنسانِ تَوصِلُهُ رزقَاً وَلادَعَةُ الإِنسانِ تَقطَعُهُ قَد وَزَّع اللَهُ بَينَ الخَلقِ رزقَهُمُ لَم يَخلُق اللَهُ مِن خَلقٍ يُضَيِّعُهُ لَكِنَّهُم كُلِّفُوا حِرصاً فلَستَ تَرى مُستَرزِقاً وَسِوى الغاياتِ تُقنُعُهُ وَالحِرصُ في الرِزقِ وَالأَرزاقِ قَد قُسِمَت بَغِيُ أَلّا إِنَّ بَغيَ المَرءِ يَصرَعُهُ وَالدهرُ يُعطِي الفَتى مِن حَيثُ يَمنَعُه إِرثاً وَيَمنَعُهُ مِن حَيثِ يُطمِعُهُ اِستَودِعُ اللَهَ فِي بَغدادَ لِي قَمَراً بِالكَرخِ مِن فَلَكِ الأَزرارَ مَطلَعُهُ وَدَّعتُهُ وَبوُدّي لَو يُوَدِّعُنِي صَفوَ الحَياةِ وَأَنّي لا أَودعُهُ وَكَم تَشبَّثَ بي يَومَ الرَحيلِ ضُحَىً وَأَدمُعِي مُستَهِلّاتٍ وَأَدمُعُهُ لا أَكُذبُ اللَهَ ثوبُ الصَبرِ مُنخَرقٌ عَنّي بِفُرقَتِهِ لَكِن أَرَقِّعُهُ إِنّي أَوَسِّعُ عُذري فِي جَنايَتِهِ بِالبينِ عِنهُ وَجُرمي لا يُوَسِّعُهُ رُزِقتُ مُلكاً فَلَم أَحسِن سِياسَتَهُ وَكُلُّ مَن لا يُسُوسُ المُلكَ يَخلَعُهُ وَمَن غَدا لابِساً ثَوبَ النَعِيم بِلا شَكرٍ عَلَيهِ فَإِنَّ اللَهَ يَنزَعُهُ اِعتَضتُ مِن وَجهِ خِلّي بَعدَ فُرقَتِهِ كَأساً أَجَرَّعُ مِنها ما أَجَرَّعُهُ كَم قائِلٍ لِي ذُقتُ البَينَ قُلتُ لَهُ الذَنبُ وَاللَهِ ذَنبي لَستُ أَدفَعُهُ أَلا أَقمتَ فَكانَ الرُشدُ أَجمَعُهُ لَو أَنَّنِي يَومَ بانَ الرُشدُ اتبَعُهُ إِنّي لَأَقطَعُ أيّامِي وَأنفقُها بِحَسرَةٍ مِنهُ فِي قَلبِي تُقَطِّعُهُ بِمَن إِذا هَجَعَ النُوّامُ بِتُّ لَهُ بِلَوعَةٍ مِنهُ لَيلى لَستُ أَهجَعُهُ لا يَطمِئنُّ لِجَنبي مَضجَعُ وَكَذا لا يَطمَئِنُّ لَهُ مُذ بِنتُ مَضجَعُهُ ما كُنتُ أَحسَبُ أَنَّ الدهرَ يَفجَعُنِي بِهِ وَلا أَنَّ بِي الأَيّامَ تَفجعُهُ حَتّى جَرى البَينُ فِيما بَينَنا بِيَدٍ عَسراءَ تَمنَعُنِي حَظّي وَتَمنَعُهُ قَد كُنتُ مِن رَيبِ دهرِي جازِعاً فَرِقاً فَلَم أَوقَّ الَّذي قَد كُنتُ أَجزَعُهُ بِاللَهِ يا مَنزِلَ العَيشِ الَّذي دَرَست آثارُهُ وَعَفَت مُذ بِنتُ أَربُعُهُ هَل الزَمانُ مَعِيدُ فِيكَ لَذَّتُنا أَم اللَيالِي الَّتي أَمضَتهُ تُرجِعُهُ فِي ذِمَّةِ اللَهِ مِن أَصبَحَت مَنزلَهُ وَجادَ غَيثٌ عَلى مَغناكَ يُمرِعُهُ مَن عِندَهُ لِي عَهدُ لا يُضيّعُهُ كَما لَهُ عَهدُ صِدقٍ لا أُضَيِّعُهُ وَمَن يُصَدِّعُ قَلبي ذِكرَهُ وَإِذا جَرى عَلى قَلبِهِ ذِكري يُصَدِّعُهُ لَأَصبِرَنَّ على دهر لا يُمَتِّعُنِي بِهِ وَلا بِيَ فِي حالٍ يُمَتِّعُهُ عِلماً بِأَنَّ اِصطِباري مُعقِبُ فَرَجاً فَأَضيَقُ الأَمرِ إِن فَكَّرتَ أَوسَعُهُ عَسى اللَيالي الَّتي أَضنَت بِفُرقَتَنا جِسمي سَتَجمَعُنِي يَوماً وَتَجمَعُهُ وَإِن تُغِلُّ أَحَدَاً مِنّا مَنيَّتَهُ فَما الَّذي بِقَضاءِ اللَهِ يَصنَعُهُ

وعليكم السلام ورحمة الله السبب أخي الفاضل بنفس سؤالك.. لأنك أمرته بأن يبحث لك بالحرف وبالتالي هو ينقل تركيزه فورا على الحرف الذي أدرجته كنتيجة لأمرك له.. وعلى ذلك تم تغيير الكود ليتجاوز عن التركيز وليستمر بعرض كل ما تدرجه له عبر مربع النص Text1.. واستغنينا عن مربع النص text2 وأضفت إليك دالة تقوم بتجاهل الحروف المهمزة بحيث كتبت مثلا (أحمد - احمد - اسراء - إسراء - آسر) يقوم بجلب جميعها.. ستفيدك جدا خصوصا مع الأسماء ملحوظة هامة.. ابتعد أخي عن المسميات المحجوزة مثل حقل Name وأيضا المسافات بين المسميات جرب ووافني بالنتيجة application - 2016.rar

وعليكم السلام أخي كرار من متابعتي لردودك في المنتدى ، كان يجب علي ان افهم انك جربت تغيير الكود المطلوب واصطدمت بهذه الرسالة ، وتوقفت عندها : وافضل طريقة للتغلب عليها ، ان ترجع الكرة الى ملعبي السبب في حصولك هذه الرسالة ، هو ان لديك معايير 3 في الاستعلام sh11 والذي يعتمد عليه الاستعلام sh . طيب ، اذا الاستعلام sh11 يستطيع ان يقرأ المعايير من النموذج ee ، فلماذا لا يستطيع الكود ان يقرأه!! والجواب ان الاكسس عبارة عن اكثر من برنامج مرتبطه ببعضها ، فمنها الـ jet والذي الان يسمى Ace من الاصدار 2007 ، وهو مسئول عن الاستعلامات وبقية امور الاكسس ، ومنها الاكسس شخصيا ، وكود VBA جزء منه ، والبرنامجين ، صحيح انهم مرتبطين ، ولكن هناك بعض الامور التي لا يتفاهمون عليها مباشرة ، بل يجب عمل وسيط بينهم ، وحل هذه الرسالة هي احد الاشياء اللي محتاجة وسيط كود اصطياد الخطأ ، في الكود المرفق ، هو حلقة الوصل ، واخذ مني الوقت الطويل لتضبيطه ليتلائم مع برمامجك ، فاعتذر عن التأخر على الرد عليك Private Sub cmd_Combine_Click() On Error GoTo err_cmd_Combine_Click 'delete the old data mySQL = "Delete * From tbl_PP" CurrentDb.Execute (mySQL) Dim rstpp As DAO.Recordset Dim rst As DAO.Recordset Dim strSql As String Set rstpp = CurrentDb.OpenRecordset("Select * From tbl_PP") '1 'j Set rst = CurrentDb.OpenRecordset("Select * From sh Order By tash") 'j2 Set rst = CurrentDb.OpenRecordset("Select * From tb_sh Order By [تاريخ الوصل]") strSql = "Select * From sh Order By [تاريخ الوصل]" Set rst = CurrentDb.OpenRecordset(strSql) rst.MoveLast: rst.MoveFirst RC = rst.RecordCount 'add all the records For i = 1 To RC rstpp.AddNew 'j rstpp!iDate = rst!tash 'j rstpp!Purchase = rst!mbsh rstpp!iDate = rst![تاريخ الوصل] rstpp!Purchase = rst!mb rstpp.Update rst.MoveNext Next i '2 'j Set rst = CurrentDb.OpenRecordset("Select * From ts Order By tats") 'j2 Set rst = CurrentDb.OpenRecordset("Select * From tb_ts Order By [تاريخ]") strSql = "Select * From ts Order By [تاريخ]" Set rst = CurrentDb.OpenRecordset(strSql) rst.MoveLast: rst.MoveFirst RC = rst.RecordCount 'we should check if the date is available, then we should use it For i = 1 To RC 'j rstpp.FindFirst "iDate=#" & rst!tats & "#" rstpp.FindFirst "iDate=#" & rst![تاريخ] & "#" If rstpp.NoMatch Then rstpp.AddNew 'j rstpp!iDate = rst!tats 'j rstpp!Payment = rst!mbts rstpp!iDate = rst![تاريخ] rstpp!Payment = rst!mblk rstpp.Update Else rstpp.Edit 'rstpp!iDate = rst!tats 'j rstpp!Payment = rst!mbts rstpp!Payment = rst!mblk rstpp.Update End If rst.MoveNext Next i rstpp.Close: Set rstpp = Nothing rst.Close: Set rst = Nothing DoCmd.OpenTable "tbl_pp" Exit Sub err_cmd_Combine_Click: If Err.Number = 3061 Then 'too few parameters, expected 1 or more 'this error occurs when trying to run a query which needs its parameters from a Form, 'the Form should be open with the parameter, then this code take the values properly Dim qdf As QueryDef Dim prm As Parameter 'Set qdf = CurrentDb.QueryDefs("strSql") Set qdf = CurrentDb.CreateQueryDef("NewQueryDef", strSql) For Each prm In qdf.Parameters prm.Value = Eval(prm.Name) Next prm Set rst = qdf.OpenRecordset(dbOpenDynaset) DoCmd.DeleteObject acQuery, "NewQueryDef" Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub جعفر 231.1.New .accdb.zip

الاخوة الاعزاء اقدم لكم جميعا هذه الهدية المتواضعه لوجه الله تعالى لا كلمات سر ولا باسوورد ولا ملفات مغلقة ولا الى حاجة برنامج اعمال كنترول التعليم الاعدادى لجمهورية مصر العربية ( باذن الله متكامل) وهى للجميع وان موجود تحت امر اى عضو للاستفسار ولكن للاسف موجود اليوم فقط باذن الله تعالى من الساعة 12:11 مساء بتوقيت القاهرة ولن افتح النت بعدها لمدة 15 يوما فأى استفسار انا تحت امر الجميع والله يعلم انه ليس هروبا ولكن الانقطاع رغما عنى وانا فى خدمة الاعضاء وكلى رجاء الا ينسبها احد لنفسة بل يدعها للجميع وبالطبع لن الح فى دعوة بظهر الغيب فانا فى اشد الحاجة اليها والسلام عليكم ورحمة الله وبركاته 003.rar