samycalls2020

أحسنت أ. هشام .. كود ممتاز وليناسب الملف لدى قمت بإضافة بسيطة أشكرك وبارك الله فيكم Sub Split_names() Dim tbl&, tmp&, i&, Max&, c&, j&, lr&, r&, s& Dim n As String, ky As Boolean, ColArr As Range, OnRng As Range Dim Arr As Variant, rng As Variant, sp As Variant Dim WS As Worksheet: Set WS = Sheets("حساب الفوائد") Dim dest As Worksheet: Set dest = Sheets("مؤشر الفائدة") Dim ColNam As String: ColNam = "DM" Max = 444 With Application .ScreenUpdating = False .Calculation = xlCalculationManual .ErrorCheckingOptions.BackgroundChecking = True End With On Error Resume Next tbl = WS.Columns("T:CC").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 tbl = WorksheetFunction.Min(WorksheetFunction.Max(tbl, 14), Max) WS.Range("DJ14:DJ" & tbl).ClearContents Set OnRng = WS.Range("T14:CC" & tbl) Arr = OnRng.Value For tmp = 1 To UBound(Arr, 1) n = "" ky = False For i = 1 To UBound(Arr, 2) If Arr(tmp, i) <> "" Then n = IIf(n = "", WS.Cells(dest.Range("AT6").Value, i + 19).Text, n & "*" & WS.Cells(dest.Range("AT6").Value, i + 19).Text) If Not ky Then WS.Cells(tmp + 13, 114).NumberFormat = WS.Cells(tmp + 13, i + 19).NumberFormat ky = True End If End If Next i WS.Cells(tmp + 13, 114).Value = n Next tmp On Error Resume Next Set ColArr = WS.Range("DG14:DG" & tbl).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not ColArr Is Nothing Then Arr = ColArr.Value ReDim rng(1 To UBound(Arr, 1), 1 To 1) For c = 1 To UBound(Arr, 1) rng(c, 1) = Arr(c, 1) Next c WS.Range("DM14").Resize(UBound(rng, 1), 1).Value = rng End If dest.Range("AS2") = 2 dest.Range("I6:AL105").ClearContents lr = WS.Cells(WS.Rows.Count, ColNam).End(xlUp).Row WS.Range("DN14:EQ" & WS.Rows.Count).ClearContents Arr = WS.Range(ColNam & "14:" & ColNam & lr).Value For j = 1 To UBound(Arr, 1) sp = Split(Arr(j, 1), "*") For r = LBound(sp) To UBound(sp) WS.Cells(j + 13, r + 118).NumberFormat = "@" WS.Cells(j + 13, r + 118).Value = sp(r) Next r Next j For s = 9 To 38 dest.Columns(s).EntireColumn.Hidden = (dest.Cells(5, s).Value = 0) Next s With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .ErrorCheckingOptions.BackgroundChecking = False End With Sheets("حساب الفوائد").Range("DN14:EQ113").SpecialCells(xlCellTypeVisible).Copy Sheets("مؤشر الفائدة").Range("I6:AL105").PasteSpecial xlPasteValues Range("I5").Select 'لإخفاء الأعمده الفارغة For s = 9 To 38 If Cells(5, s).Value = "" Then Columns(s).EntireColumn.Hidden = True Else Columns(s).EntireColumn.Hidden = False End If Next s Application.ScreenUpdating = False 'إحتواء منسب الأعمده For s = 9 To 38 Columns(s).AutoFit Next s End Sub

أ. محمد هشام .. أنا أسف لتعبك معايا .. لك كل التقدير لم أجد بد غير وضع الملف الأصلى بعد إجراء بعض التغيرات الكود بالملف ممتاز وهو كودك بالأساس وهناك جزء فى الكود قمت أنا بعمله يعطى نتيجه جيده ولكن به بعض الملاحظات .. لذلك أود تغيره بكودك المتقن وهو موجود باللون الأخضر وحاولت تشغيله ولكن كانت المشكلة التى أسلت لك صورتها Option Explicit Sub Split_names() Dim sp As Variant, j&, lr&, i& Dim WS As Worksheet: Set WS = ActiveSheet With Application .ScreenUpdating = False: .Calculation = xlCalculationManual .ErrorCheckingOptions.BackgroundChecking = True End With lr = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row WS.Range("C14:AF" & lr).ClearContents For j = 14 To lr sp = Split(WS.Cells(j, "B").Value2, "*") For i = LBound(sp) To UBound(sp) WS.Cells(j, i + 3).NumberFormat = "@" WS.Cells(j, i + 3).Value = sp(i) Next i Next j With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic .ErrorCheckingOptions.BackgroundChecking = False End With End Sub نسب ومؤشر الفائدة222.xlsb

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

مجهود رائع أ. أبو عيد بارك الله لك ولكن هناك ملحوظتان إن سمحت لى 1- الاسم الأخير أو الرقم الأخير فى كل صف لايظهر 2- الأرقام التى هى أقل من الألف لاتظهر بها العلامة العشرية مثل 312 فالمراد أن تظهر 312.00 كما فى الصف 3 والصف 7

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

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

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

لم أقصد الإساءه لأحد والله أعلم بالنوايا .. وأعود وأكرر الشكر للجميع

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

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

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

الشكر والعرفان لك أ.عبدالله بشير

أشكرك أ. عبد الله على مجهودك الكبير لاحظت الحل فى هذا السطر names = names & IIf(names = "", "", " - ") & ws.Cells(5, colIndex).Value يغير رقم 5 إلى رقم الصف المطلوب

الحل بالكود ممتاز أخى الكريم .. عبد الله ولكن لو أردت أن يكون الحل على صف3 أو صف4 بدل صف 5 .. كما فى المرفق فما هو التعديل للكود DATA2.xlsb

السلام عليكم .. هذا جدول أود استخراج الأسماء أو القيم منه بمعادلة كما هو موضح والشكر لكم مقدماً DATA.xlsx

السلام عليكم أ. محمد هشام في البداية كل التعازي والمواساة في مصابكم الجليل لك وللشعب المغربي الشقيق نسأل الله العلى القدير أن يتغمد من وافته المنية في هذا الزلزال بعظيم الرحمة والمغفرة وأن ينزلهم منازل الشهداء وأن ينعم ويتم الشفاء على المصابين .. آمين .. أتوجه بالشكر الجزيل على ما قدمته بهذا الصدد وعلى هذا الكود الرائع وعلى شرح محتواه .. دائماً نتعلم منك .. بارك الله فيكم ولكم وكل التحية والاحترام

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

السلام عليكم تم الترتيب في J3 القائمة المنسدلة سوء كان أبجدي أو رقمي كما ذكرت سابقاً وتم تحديد مدى الفرز والتصفية ب 3352 صف ويمكن التغير حسب الطلب والحاجة وشكراً لكل من شارك وساعد الخزينة3 معدل.xlsb

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

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

أخي الكريم / أبو أحمد .. السلام عليكم كل التحية والتقدير لمجهودك الكبير . وإن كنت أتمنى أن يكون الحل من خلال التطبيق الموجود بالملف بمعنى من خلال اصلاح كود الفرز عموما اسمح لي في بعض الملاحظات من خلال تجربتي السريعة للعمل الذى قدمته ولك لكل تحية وشكر علية . * بداية عمود التصفية من صف 11 وشرط التصفية من صف 12 ويفضل أن يكون عمود التصفية بأسماء صف العناوين رقم6 وشرط التصفية من صف رقم7 أي بداية الجدول . * عدم وجود تسلسل رقمي وأبجدي بشرط التصفية . * تصفية الأرقام لا تعمل لأنها تظهر في شرط التصفية بدون علامة ( 0.00 ) من مائة ، وبالتالي تصفية عمود F وعمود H لا تعمل . * عمود التصفية يظهر به التاريخ الشهر قبل اليوم . * عند الضغط على عمود التصفية وشرط التصفية تتحول الأرقام والتواريخ الى العربية وعند ترك الضغط تعود للإنجليزية . * الأرقام تظهر في القائمتين والخاصة برصيد الخزينة بعمود L بكسر كبير والمفترض أن يكون أي رقم بكسر( 0.00 ) من مائة . تقبل تحياتي

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

نعم هو المطلوب .. كل الشكر والتقدير

شكراً أ. محمد صالح على مشاركتك القيمة

السلام عليكم ما أطلبه من حضراتكم هو تبديل كلمة "طب" في الماكرو واستبدالها بخلية H2 التي تحتوى على قائمة منسدلة بحيث يمكن تغير ما نبحث عنه , وطبعاً ما يترتب على ذلك من تعديل في الكود . وشكراً على تفضلكم بالمساعدة Sub بحث_وانتقال() If Intersect(ActiveCell, Range("C6:C45")) Is Nothing Then Range("C6").Select Range("C6:C45").Find("طب", ActiveCell, xlValues).Select End Sub الكليات 2022.xlsm