ياسر خليل أبو البراء

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

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

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

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

اطلع على هذا الملف ربما يفيدك .. Protect Formulas Only.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 تقبل تحياتي

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

أخي الكريم عبد العزيز أعتقد أنني أرشدتك إلى موضوع البداية لكيفية التعامل مع الأكواد .. عموماً للاستزادة ... وإنت واقف في ورقة العمل اضغط Alt + F11 للدخول لمحرر الأكواد من قايمة Insert اختر كلمة Module ليتم إدراج موديول جديد انسخ الكود والصقه في الموديول روح لورقة العمل واضغط Alt + F8 هيطلع لك نافذة فيها أسماء الإجراءات الفرعية (الأكواد) اختر الكود المسمى ClearSheet وانقر الأمر Run ليقوم بالتنفيذ بالنسبة للأكواد حاول تجربها على نسخة من الملف الأصلي ولا تقم بالحفظ إلا بعد التأكد من عمل الكود لأنه لا تراجع مع الأكواد تقبل تحياتي

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

أخي الكريم قم بالذهب إلى موضوع التوجيهات في الموضوعات المثبتة في المنتدى وراجع التوجيه العاشر .. أين الملف المرفق؟

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

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

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

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

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

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

أخي الكريم خالد للأسف دالة INDIRECT لاتعمل مع المصنفات المغلقة ..لو تم فتح الملف ستعطيك نتائج صحيحة

أخي الكريم أفضل إرفاق الملف الأصلي مع مزيد من التوضيح للمطلوب بدقة وسؤال هل الملفات في نفس مسار المصنف الحالي الذي سيحوي الكود المطلوب أم لا؟

أخي الحبيب عبد العزيز المدني عدلت في الكود بشكل كبير بحيث يكون مرن وتستطيع التعديل عليه بكل سهولة كل ما عليك هو التعديل في الأسطر التي تلي التعليقات .. السطر الأول خاص بصف البداية أي أول صف يحتوي على بداية الأسماء والتعديل الثاني هو رقم العمود الموجود فيه الأسماء ..اكتب رقم العمود فإذا كان العمود هو العمود 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

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

أخي الكريم مرسال بالنسبة لطلبك الأول وهو ترحيل الأسماء التي يحتوي الصف الخاص بها على أرقام جرب هذا الكود Sub TransferData() Dim Ws As Worksheet, Sh As Worksheet Dim LR As Long, LastRow As Long, I As Long Set Ws = Sheet1: Set Sh = Sheet2 LR = Ws.Cells(Rows.Count, "D").End(xlUp).Row Application.ScreenUpdating = False For I = 4 To LR If Application.WorksheetFunction.Count(Ws.Range("G" & I & ":AK" & I)) >= 1 Then LastRow = Sh.Cells(Rows.Count, "C").End(xlUp).Row + 1 Sh.Range("B" & LastRow).Resize(1, 37).Value = Ws.Range("B" & I).Resize(1, 37).Value End If Next I Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub أما فيما يخص باقي طلباتك وإن كنت أفضل التعامل مع الطلبات كل طلب بموضوع ، لتجد استجابة أكثر من قبل إخوانك بالمنتدى يرجى توضيح المطلوب بالنسبة للجمع مع ضرب مثال أو مثالين لتتضح الصورة وهل تريد الجمع في ورقة main أم في ورقة اضافي التي سيتم الترحيل إليها ..