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