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

السلام عليكم ورحمة الله وبركاته اليك الحل خيثر.rar

عندما تقوم بعمل تقرير ووضع تعليقات بيه (comments ) و تريد طباعه التقرير بالتعليقات فيتم عمل الخطوات الاتيه قبل الطباعه1- اظهار جميع التعليقات بالضغط على show all comments2- فتح شاشه page setup3- فتح تبويب sheet4- اختيار احد البدائل فى طباعه التعليقات كما فى الصوره المرفقه

رااااااااااائع عندى حق أنا لما بقول إنك أستاذى ولا لأ ؟

السلام عليكم ورحمة الله وبركاته هديتي إليك أخي الحبيب ياسر العربي اللهم اجعلنا من أهل الحسنى وزيادة للذين أحسنوا الحسنى وزيادة تمعنوا في قول الله تعالى:( للذين أحسنوا الحسنى وزيادة ولا يرهق وجوههم قتر ولا ذلة أولئك أصحاب الجنة هم فيها خالدون ( 26 ) ) يخبر تعالى أن لمن أحسن العمل في الدنيا بالإيمان والعمل الصالح أبدله الحسنى في الدار الآخرة ، كما قال تعالى : ( هل جزاء الإحسان إلا الإحسان ) [ الرحمن : 60 ] . وقوله : ( وزيادة ) هي تضعيف ثواب الأعمال بالحسنة عشر أمثالها إلى سبعمائة ضعف ، وزيادة على ذلك [ أيضا ] ويشمل ما يعطيهم الله في الجنان من القصور والحور والرضا عنهم ، وما أخفاه لهم من قرة أعين ، وأفضل من ذلك وأعلاه النظر إلى وجهه الكريم ، فإنه زيادة أعظم من جميع ما أعطوه ، لا يستحقونها بعملهم ، بل بفضله ورحمته وقد روي تفسير الزيادة بالنظر إلى وجه الله الكريم ، عن أبي بكر الصديق ، وحذيفة بن اليمان ، وعبد الله بن عباس [ قال البغوي وأبو موسى وعبادة بن الصامت ] وسعيد بن المسيب ، وعبد الرحمن بن أبي ليلى ، وعبد الرحمن بن سابط ، ومجاهد ، وعكرمة ، وعامر بن سعد ، وعطاء ، والضحاك ، والحسن ، وقتادة ، والسدي ، ومحمد بن إسحاق ، وغيرهم من السلف والخلف . وقد وردت في ذلك أحاديث كثيرة ، عن رسول الله صلى الله عليه وسلم ، فمن ذلك ما رواه الإمام أحمد : حدثنا عفان ، أخبرنا حماد بن سلمة ، عن ثابت البناني ، عن عبد الرحمن بن أبي ليلى ، عن صهيب ؛ أن رسول الله صلى الله عليه وسلم تلا هذه الآية : ( للذين أحسنوا الحسنى وزيادة ) وقال : " إذا دخل أهل الجنة الجنة ، وأهل النار النار ، نادى مناد : يا أهل الجنة ، إن لكم عند الله موعدا يريد أن ينجزكموه . فيقولون : وما هو ؟ ألم يثقل موازيننا ، ويبيض وجوهنا ، ويدخلنا الجنة ، ويزحزحنا من النار ؟ " . قال : " فيكشف لهم الحجاب ، فينظرون إليه ، فوالله ما أعطاهم الله شيئا أحب إليهم من النظر إليه ، ولا أقر لأعينهم " . وهكذا رواه مسلم وجماعة من الأئمة ، من حديث حماد بن سلمة ، به . [ ص: 263 ] وقال ابن جرير : أخبرنا يونس ، أخبرنا ابن وهب : أخبرنا شبيب ، عن أبان عن أبي تميمة الهجيمي ؛ أنه سمع أبا موسى الأشعري يحدث عن رسول الله صلى الله عليه وسلم : " إن الله يبعث يوم القيامة مناديا ينادي : يا أهل الجنة - بصوت يسمع أولهم وآخرهم - : إن الله وعدكم الحسنى وزيادة ، الحسنى : الجنة . وزيادة : النظر إلى وجه الرحمن عز وجل " . ورواه أيضا ابن أبي حاتم ، من حديث أبي بكر الهذلي عن أبي تميمة الهجيمي ، به . وقال ابن جرير أيضا : حدثنا ابن حميد ، حدثنا إبراهيم بن المختار عن ابن جريج ، عن عطاء ، عن كعب بن عجرة ، عن النبي صلى الله عليه وسلم في قوله : ( للذين أحسنوا الحسنى وزيادة ) قال : النظر إلى وجه الرحمن عز وجل . وقال أيضا : حدثنا ابن عبد الرحيم حدثنا عمرو بن أبي سلمة ، سمعت زهيرا عمن سمع أبا العالية ، حدثنا أبي بن كعب : أنه سأل رسول الله صلى الله عليه وسلم عن قول الله عز وجل : ( للذين أحسنوا الحسنى وزيادة ) قال : " الحسنى : الجنة ، والزيادة : النظر إلى وجه الله عز وجل " . ورواه ابن أبي حاتم أيضا من حديث زهير ، به . وقوله تعالى : ( ولا يرهق وجوههم قتر ) أي : قتام وسواد في عرصات المحشر ، كما يعتري وجوه الكفرة الفجرة من القترة والغبرة ، ( ولا ذلة ) أي : هوان وصغار ، أي : لا يحصل لهم إهانة في الباطن ، ولا في الظاهر ، بل هم كما قال تعالى في حقهم : ( فوقاهم الله شر ذلك اليوم ولقاهم نضرة وسرورا ) أي : نضرة في وجوههم ، وسرورا في قلوبهم ، جعلنا الله منهم بفضله ورحمته ، آمين .

السلام عليكم - اسعد الله أوقاتكم : الزملاء المحاسبون – الأساتذة المحترمون مرفق ملف اكسل يحوي برنامجين عن احتساب نسب التحليل المالي والتحليل المقارن ( النسب الرئيسية والهامة فقط ) مع استخلاص تفسير لكل نسبة البرامج تحتوي معادلات بسيطة جدا – والغاية هي كيفية استثمار الاكسل في استخلاص نسب التحليل المالي الفكرة بالأصل لاساتذتي: ( عبد الله المدني + محمد فوزي سلام ) / + ياسرالحافظ البرامج تحتوي النسب الرئيسية ويمكن للمستثمر إضافة النسب التي تلزم لعمل مؤسسته حيث أرفقت ملف وورد بمعظم نسب التحليل المالي مع شروحات وتفسيرات وفقكم الله ياسر الحافظ " ابو الحارث " تحليل مالي اكسل.rar

السلام عليكم ورحمة الله تعالى وبركاته بفضل الله تعالى تم انجاز المشروع والحمد لله وذلك لطلب الاخوة فى هذا الموضوع http://www.officena.net/ib/index.php?showtopic=62339&hl= الموضوع يتلخص فى نظام مراسلة وارسال رسالة بين المستخدمين لقاعدة البيانات شبيه بالفيس بوك صفحة تسجيل الدخول قمت باضافة شى مهم جدا وهو ربط نموذج باستضافة مجانيه به جدول وضعته اذا احببت ارسال تعليق لى بخصوص البرنامج شكر الله لكم جميعا والاكواد الخاصة بهذا الربط مدرجة فى هذا الموضوع http://www.officena.net/ib/index.php?showtopic=61514 الصفحة الشخصية بها قائمة الاصدقاء ونظام المراسلة منصة عرض الرسائل والارشفة قوائم الاعضاء ويمكنك اضافة الاصدقاء الى قائمة اصدقائك والان مع البرنامج تحياتى

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

وفقك الله ومنك نتعلم وجزاك الله خير وربنا يوفقك

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

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

أخي الكريم المسلم العربي يرجى تغيير اسم الظهور ليعبر عن شخصكم الكريم (وهذا ليس أول نداء لك) جرب الكود التالي عله يكون المطلوب Private Sub ComboBox1_Change() Dim Ws As Worksheet Application.ScreenUpdating = False On Error Resume Next For Each Ws In Worksheets If Ws.Name <> "Info" Then If ComboBox1.Value = Ws.Range("A1").Value Then Ws.Activate: Exit For Else Sheets("Info").Activate End If Next Ws Application.ScreenUpdating = True End Sub وإن لم يكن المطلوب فيرجى التوضيح أكثر تقبل تحياتي

أخي الكريم سعيد بيرم يبدو أننا لم نصل لاتفاق بعد في موضوع توضيح المطلوب .. الأكواد ليست أسطر أحفظها ..ربما أكتب كود وبعد ربع ساعة أنسى الأسطر التي كتبتها وهذا أمر طبيعي ربما معي ، عندما أشرع بكتابة الكود أبدأ بسطر سطر ثم أقوم بفحص الأسطر التي كتبت وهكذا إلى أن تكتمل الفكرة والكود وأفحص الكود أكثر من مرة ، ولكل ملف ولكل ورقة عمل طبيعة خاصة تختلف بشكل دائم .. فمع إضافة أعمدة جديدة كما فعلت كان لابد من مراجعة الكود من جديد سطر بسطر ، وما زاد الموضوع تعقيد أنك تريد دمج كودين وكل كود فيه متغيرات معرفة مشابهة للكود الآخر مما اضطرني إلى تغيير المتغيرات كلها من جديد ليعمل الكود بسلاسة ، وصدقني إذا قلت لك أن التعديل على الكود أصعب من كتابته من جديد عموماً جرب الكود التالي عله يفي بالغرض Sub TransferMatchingData() Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet Dim Cel As Range, Found As Range Dim LR As Long, LastRow As Long Dim X As Long, I As Long Set Ws1 = Sheet1: Set Ws2 = Sheet2: Set Ws3 = Sheet3 Application.ScreenUpdating = False On Error Resume Next LR = Ws1.Cells(Rows.Count, 1).End(xlUp).Row LastRow = Ws3.Cells(Rows.Count, "E").End(xlUp).Row + 1 For Each Cel In Ws1.Range("B8:B" & LR) Set Found = Ws2.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).Value = Cel.Offset(, 1).Value Found.Offset(, 4).Value = Cel.Offset(, 4).Value End If Next Cel With Ws1 .AutoFilterMode = False .Range("A7:D7").AutoFilter Field:=3, Criteria1:="<>" & "" .Range("B8:C" & LR).SpecialCells(xlCellTypeVisible).Copy Ws3.Cells(LastRow, "E").PasteSpecial xlPasteValues .Range("F8:F" & LR).SpecialCells(xlCellTypeVisible).Copy Ws3.Cells(LastRow, "G").PasteSpecial xlPasteValues Ws3.Cells(LastRow, "B").Value = Ws1.Range("B6").Value Ws3.Cells(LastRow, "D").Value = Ws1.Range("F6").Value Ws3.Cells(LastRow, "C").Value = Ws1.Range("C3").Value .AutoFilterMode = False End With Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Done...", vbInformation, "YasserKhalil" End Sub تقبل تحياتي

تفضل مثالك بعد التعديل اخذ نسخة احتياطية بالتاريخ والوقت مع تحديد مكان الحفظ ويمكن ان تعدله بحيث يكون الحفظ افتراضيا في مجلد بجانب قاعدة البيانات JandbiUP.rar

أخي الكريم كمال هل أنت متأكد من عمل الكود الذي قمت بإرفاقه لأن الكود المرفق يقوم بعمل حلقة تكرارية لملفات تختارها ثم يقوم بنسخ نطاق محدد عموماً جرب الكود التالي سيتم تنفيذه بمجرد فتح الملف الرئيسي س .. Sub SUM_WBs() Dim WBK As Workbook Dim FolderPath As String Dim FileName As String Dim Counter As Double FolderPath = ThisWorkbook.Path & "\" FileName = Dir(FolderPath & "*.xl*") Application.ScreenUpdating = False Application.Calculation = xlManual Do While FileName <> "" If FileName <> ThisWorkbook.Name Then Set WBK = Workbooks.Open(FolderPath & FileName) Counter = Counter + WBK.Sheets("Sheet1").Range("A1").Value WBK.Close SaveChanges:=False End If FileName = Dir() Loop ThisWorkbook.Sheets("Sheet1").Range("A1").Value = Counter Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub وإليك الملف المرفق Loop Through Closed Workbooks To Sum Specific Cell YasserKhalil.rar

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

استبدل المعادلة بهذه =INT(($D$2-(HOUR(SUM($C$3:$C$16))+MINUTE(SUM($C$3:$C$16))/60))*60/60)&" H"& " : "&INT(MOD(($D$2-(HOUR(SUM($C$3:$C$16))+MINUTE(SUM($C$3:$C$16))/60))*60,60))+1&" Mins."

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

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

وعليكم السلام هذه طريقتي: http://www.officena.net/ib/topic/59818-اعمل-برنامجك-بعدة-لغات-وببساطة/ جعفر

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

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

اخي الغالي ارجو الالتزام بتوجيهات المنتدى وما ذكره اخي الغالي ابو البراء ثم انك طلبت الملف بتعديلات معينة في موضوع اخر وتم الرد عليك من قبلي ولم تعطى اي رد بعمل الملف معك تماما ام هناك بعض المشاكل وكان من الافضل ذكر تعديلك في نفس الموضوع ويتم الاجابة عنه في نفس الموضوع من شكل الكود اقول لك انه الصورة المراد اختيارها لا توجد في المسار ولتجنب هذا الخطأ ضع هذا السطر في اول الكود لتخطى الاخطاء On Error Resume Next اي ملاحظات ضع (مرفقا) وشكرا

أخي الكريم مختار الأرقام في الكود التالي عبارة عن أول خلية مفردة بعد الخلايا المدمجة (والتي عددها 30 خلية : هي 10 خلايا مدمجة * كل خلية مدمجة = 3 خلايا مفردة) لاحظت أن نتائج الكود عبارة عن 7 و 17 و 27 ... فقمت بعمل السطر في الكود السابق بناءً على ذلك بأن قيمة المتغير I تزيد 10 إذا كان أول رقم في الناتج من ناحية اليمين يساوي 7 .. Sub Test() MsgBox 37 Mod 30 MsgBox 77 Mod 30 MsgBox 117 Mod 30 MsgBox 157 Mod 30 MsgBox 197 Mod 30 End Sub لو عندك فكرة تانية أرحب بها لأن الفكرة جات كدا معايا مش مدروسة مجرد خيالات بعض الإبداع تقبل تحياتي

هل من الممكن رفع البرنامج للمساعده

تفضل أخي الكريم Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 And Target.Row > 1 And Target.Row < 5001 And Target.Value = "ف" Then Application.EnableEvents = False With Target Target.Value = Time Target.NumberFormat = "hh:mm:ss" Columns(Target.Column).EntireColumn.AutoFit End With Application.EnableEvents = True End If End Sub

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

جرب هذا الملف تم جماية المعادلات لعدم العبث بها عن طرق الحطأ كلمة السر للتعديل 123 كشف اسماء طالبات الاعداديةة2016 2ج salim.rar

كلمة Fieldتعني الحقل و هنا المراد بها بأي حقل (عامود) من الجدول نريد ان تتم التصفية طبعاً الرقم 3يغني العامود الثالث كلمة Criteria1 تعني المعيار و رقم واحد المعيار الاول حيث يمكنك ادراج اكثر من معيار واحد للتصفية

جرب الكود بهذا الشكل (لم أختبر الكود) فقط قمت بإضافة نقطة قبل كلمة Cells للإشارة إلى ورقة العمل التي سيكون عليها الدور في الحلقة التكرارية دون تنشيط الورقة Sub DelAllData() Dim Ws As Worksheet Application.ScreenUpdating = False For Each Ws In ThisWorkbook.Worksheets With Ws .Range(.Cells(4, "A"), .Cells(Rows.Count, "J")).ClearContents End With Next Ws Sheets("Data").Activate Application.ScreenUpdating = True End Sub

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

هل تقصد أن السطر ضروري استخدامه ؟ لو كان ضروري فأكيد هناك طريقة تجعلك تستغنى عنه لا يحبذ استخدام Select و Activate في كتابة الكود إذ أنه يسبب بطء في التنفيذ

أخي الحبيب مختار ليه السطر ده .. .Activate أطن فهمتني ..

أخي الكريم هذا ملف آخر يمكنك من اختيار الملف الذي تريد فتحه ... Open Excel File Using File Dialog On UserForm.rar

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

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

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

أخي الكريم نايف الكود الذي قدمته يعتمد على اسم ورقة العمل وعنوان الخلية ثم يجلب الرقم .. الكود المقدم من قبل أخونا رجب يقوم بالبحث عن الرقم وجلب اسم ورقة العمل وعنوان الخلية ، وكذلك الفورم الرائع الذي قدمه أخونا حسام يقوم بنفس المهمة يعني تجيبها كدا شغالة وكدا شغالة .. تقبل تحياتي

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

يا سلام شو هالكود أستاذ ياسر روعة يعني : نضع الكود في مودول ثم نكتب الرقم المراد البحث عنه ثم نشغل الكود

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

بعد اذن استاذى الفاضل / رجب جاويش والاستاذ الفاضل / ياسر خليل مرفق حل اخر باستخدام الاكواد بالفورم يتم كتابه الرقم المطلوب فى التكست بوكس باللون الابيض وشاهد النتائج فى اليست بوكس باللون الاصفر ولاظهار الفورم يتم الضغط على f6 سيظهر الفورم تقبلوا تحياتى ======================================== مثال.zip

أخى الصقر أخى ياسر ما فهمته أنا من سؤال الأخت الفاضلة كالاتى : يوضع رقم فى الخلية A3 ثم يتم البحث عنه وعند ايجاده يتم وضع اسم الصفحة التى يوجد بها فى الخلية B3 واسم الخلية الذى يوجد بها الرقم فى الخلية C3

ولاثراء الموضوع هذا كود آخر Private Sub Worksheet_Change(ByVal Target As Range) Dim LR As Long, x As Long, i As Integer, D As Boolean Dim ws As Worksheet, cl As Range '================================================== If Target.Address = [A3].Address Then x = Val([A3]) For i = 1 To 3 LR = Sheets(i).Range("A10000").End(xlUp).Row For Each cl In Sheets(i).Range("A1:A" & LR) If cl = x Then [B3] = Sheets(i).Name [C3] = cl.Address(0, 0) D = True Exit For End If Next Next If Not D Then Range("B3:C3") = "رقم غير موجود" End If End Sub مثال2.rar

الأخت الكريمة ربا إليك الكود التالي عله يفي بالغرض Sub SearchSheets() Dim Cel As Range, strSheet As String, strAddress As String For Each Cel In Sheet4.Range("B3:B" & Sheet4.Cells(Rows.Count, 2).End(xlUp).Row) strSheet = Cel.Value: strAddress = Cel.Offset(, 1).Value If Evaluate("ISREF('" & strSheet & "'!A1)") And strAddress <> "" Then Cel.Offset(, -1).Value = Sheets(strSheet).Range(strAddress).Value Next Cel End Sub

بعد اذن أخى الفاضل سليم جرب أخى هذه الفكرة تم عمل قائمة غير مكررة من اسم القرية وخطوط العرض والطول الخاصة بها فى الأعمدة J , K , L وتم عمل قائمة منسدلة فى العمود E كما تريد وعند اختيار اسم القرية يظهر خط الطول وخط العرض تلقائيا فى الخلايا المجاورة ملاحظة : عند وجود قرى جديدة يتم اضافتها واضافة خط العرض وخط الطول الخاص بها فى الأعمدة J , K , L وسوف يتم اضافتها تلقائيا الى القائمة المنسدلة المرنة please 1.rar

أخي الكريم عاشق الإكسيل كنت أتمنى أن تقوم بإضافة كود ولو بشكل مبدئي وليس كامل لتستطيع أن تقوم بالأمر بنفسك عموماً جرب الكود التالي وشوف هل يؤدي الغرض أم أن هناك مشاكل به Sub EditAfterRecall() Dim WS As Worksheet, SH As Worksheet Dim TargetRow As Long, LR As Long, RowsToInsert As Long Dim LastRow As Long, I As Long, Arr Set WS = Sheet1: Set SH = Sheet3 If IsError(Application.Match(WS.[M5].Value, SH.[A1:A2000], 0)) Then MsgBox "رقم الإذن غير موجود في ورقة الأرشيف", 64: Exit Sub Else With Application .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False End With TargetRow = Application.Match(WS.[M5].Value, SH.[A1:A2000], 0) LR = IIf(SH.Range("A" & TargetRow).End(xlDown).Row >= Rows.Count, SH.Range("I" & Rows.Count).End(xlUp).Row + 1, SH.Range("A" & TargetRow).End(xlDown).Row) SH.Rows(TargetRow & ":" & LR - 1).Delete Shift:=xlUp RowsToInsert = Application.WorksheetFunction.CountA(WS.Range("F20:F33")) SH.Rows(TargetRow).Resize(RowsToInsert).Insert Shift:=xlDown With SH.Rows(TargetRow).Resize(RowsToInsert) .Interior.Color = xlNone .Font.ColorIndex = xlAutomatic .Font.Size = 13 End With 'ترحيل البيانات LastRow = WS.Cells(33, "F").End(xlUp).Row Arr = Array("M5", "M2", "D6", "C10", "C12", "C16") For I = 0 To UBound(Arr) If IsEmpty(WS.Range(Arr(I))) Or LastRow < 20 Then MsgBox "البيانات غير مكتملة", vbCritical: Exit Sub Next I For I = 0 To UBound(Arr) SH.Cells(TargetRow, I + 1) = WS.Range(Arr(I)) Next I WS.Range("P20:R" & LastRow).Copy SH.Range("G" & TargetRow).PasteSpecial xlPasteValues MsgBox "تم تعديل البيانات بنجاح", 64 With Application .CutCopyMode = False .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True End With End If End Sub تقبل تحياتي

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

هذه قاعدة بيانات مفتوحة بالسورس كود هي قاعدة بيانات أجنبية وجدتها في إحدى المنتديات الأجنبية مع العلم أنني الأن أحاول وضعها بقوائم عربية أتمنى من الجميع الاستفادة منها program.rar