samycalls2020

وعليكم السلام أ. عبد الله بارك الله فيك ونفعنا بعلمك تحياتى

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

شكراً على مجهودك ووقتك أ. عبد الله بشير

أ. عبد الله بشير .. السلام عليكم , وشكراً لإهتمامك مرفق الملف , أما عن الكود فهو كود تلقائى وآخر نفس التكوين بزر شهادات.xlsb

السلام عليكم ورحمة الله وبركاته لدى كود جيد ويؤدى وظيفتة بدقه وهو يتعامل مع ثلاث أوراق طلبى هو زيادة سرعته فهو يأخذ حوالى 7 ثوانى فى تنفيذ مهامه شكراً لكم وبالتوفق 'كود جلب بيانات Private Sub Worksheet_Change(ByVal Target As Range) If Cells(4, 2).Value = "ON" Then ' لإيقاف وتشغيل الكود Dim ws As Worksheet, tbl As Long, tmp As Long, i As Long Dim n As String, Max As Long, ky As Boolean Max = 461 If Not Intersect(Target, Range("D2,D4,B4,B7")) Is Nothing Then Set ws = Sheets("حساب الفوائد") Set SA = Sheets("مؤشر الفائدة") Set SB = Sheets("P") '------------------------------------------------------------------------------------------ 'استخراج البيانات المطلوبة من بيانات الشهادات 'On Error Resume Next Application.ScreenUpdating = False Application.Calculation = xlCalculationAutomatic SA.Range("BH2") = 2 'مسح البيانات من منطقة منطقة عرض البيانات SA.Range("D6:BC207").ClearContents ws.Range("DN26:FA225").ClearContents ws.Range("FG26:HF225").ClearContents '-------------------------------------------------------------------------------------------------- 'فك البيانات Application.ScreenUpdating = False Dim sp As Variant, j&, lr& With Application .ScreenUpdating = False: .Calculation = xlCalculationManual .ErrorCheckingOptions.BackgroundChecking = True End With lr = ws.Cells(ws.Rows.Count, "DK").End(xlUp).Row For j = 26 To lr sp = Split(ws.Cells(j, "DK").Value2, "*") For i = LBound(sp) To UBound(sp) ws.Cells(j, i + 118).NumberFormat = "@" ws.Cells(j, i + 118).Value = sp(i) Next i Next j With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic .ErrorCheckingOptions.BackgroundChecking = False End With '------------------------------------------------------------------------------------------- 'نسخ البيانات المفككة إلى إلى ورقة عرض البيانات Application.ScreenUpdating = False ws.Range("DN26:FA225").SpecialCells(xlCellTypeVisible).COPY ws.Range("FL26:GY225").PasteSpecial xlPasteValues '--------------------------------------------------------------------------------------------- 'معادلة لضرب عدد الأشهر فى قيمة الفائدة الشهرية If SA.Range("BJ4") = 33 Then ws.Range("FL26:GY26") = ws.Range("FL25:GY25").Formula ws.Range("FL26:GY26").AutoFill Destination:=ws.Range("FL26:GY225"), Type:=xlFillDefault End If '----------------------------------------------------------------------------------------------- Application.ScreenUpdating = False 'معادلات لتكون صفحة العرض بلا معادلات If SA.Range("BJ4") = 33 Or SA.Range("BJ4") <> 33 Then ws.Range("FG26:FK225") = ws.Range("FG25:FK25").Formula ws.Range("FG26:FK225") = ws.Range("FG26:FK225").Value ws.Range("GZ26:HF225") = ws.Range("GZ24:HF24").Formula ws.Range("GZ26:HF225") = ws.Range("GZ26:HF225").Value SA.Range("D7:H7") = ws.Range("FG24:FK24").Value SA.Range("F4:H6") = ws.Range("FI21:FK23").Value SA.Range("AW6:BC7") = ws.Range("GZ22:HF23").Value End If ' ----------------------------------------------------------------------------------------------- ws.Range("FL24:GY24").SpecialCells(xlCellTypeVisible).COPY SA.Range("I7:AV7").PasteSpecial xlPasteValues ws.Range("FG26:HF225").SpecialCells(xlCellTypeVisible).COPY SA.Range("D8:BC207").PasteSpecial xlPasteValues ' ----------------------------------------------------------------------------------------------- Application.ScreenUpdating = False SB.Range("D8:L208").ClearContents SA.Range("D6:H207").SpecialCells(xlCellTypeVisible).COPY SB.Range("D7:H208").PasteSpecial xlPasteValues SA.Range("F4:H6").SpecialCells(xlCellTypeVisible).COPY SB.Range("F5:H7").PasteSpecial xlPasteValues ws.Range("HI25:HL225").SpecialCells(xlCellTypeVisible).COPY SB.Range("I8:L208").PasteSpecial xlPasteValues SA.Range("J5") = SA.Range("BQ5").Value ' ----------------------------------------------------------------------------------------------- 'لإخفاء الأعمده الفارغة Application.ScreenUpdating = False For s = 9 To 54 If Cells(7, s).Value = "" Then Columns(s).EntireColumn.Hidden = True Else Columns(s).EntireColumn.Hidden = False End If Next s 'إحتواء منسب الأعمده For s = 9 To 54 If Cells(7, s).Value <> "" Then Columns(s).AutoFit End If Next s '------------------------------------------------------------------------------------------ 'لتغير الخطوط Application.ScreenUpdating = False If Sheets("مؤشر الفائدة").Range("B7") = 1 Then Sheets("مؤشر الفائدة").Range("AY8:AY207, BB8:BB208,BR2:BR4").Select With Selection.Font .Name = "Wingdings 3" .Size = 14 Selection.HorizontalAlignment = xlCenter End With End If If Sheets("مؤشر الفائدة").Range("B7") = 2 Then Sheets("مؤشر الفائدة").Range("AY8:AY207, BB8:BB208,BR2:BR4").Select With Selection.Font .Name = "Arial" .Size = 16 Selection.Font.Bold = True Selection.HorizontalAlignment = xlCenter End With End If If Sheets("مؤشر الفائدة").Range("B7") = 3 Then Sheets("مؤشر الفائدة").Range("AY8:AY207, BB8:BB208,BR2:BR4").Select With Selection.Font .Name = "Arial" .Size = 16 Selection.HorizontalAlignment = xlCenter End With End If Application.ScreenUpdating = False '----------------------------------------------------------------------------------------- ' لتلوين برواز الخلية ALP Application.ScreenUpdating = False If SA.Range("BJ6") = 5 Then SA.Range("AZ6").Select With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Color = -10839132 End With With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Color = 0 End With End If If SA.Range("BJ6") <> 5 Then SA.Range("AZ6").Select With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Color = 0 With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Color = -10839132 End With End With End If ' ------------------------------------------------------------------------------------------------ 'P للتنسيق فى ورقة Sheets("P").Select Application.ScreenUpdating = False If Sheets("P").Range("I8") = "إجمــاليــات" Then Sheets("P").Range("$I$9:$J$208").Select With Selection.Font Selection.HorizontalAlignment = xlRight Selection.NumberFormat = "#,##0.00" Sheets("P").Range("$I$7:$J$208").Select Selection.Columns.AutoFit Sheets("P").Range("$K$8").Select Selection.Columns.Hidden = False End With Sheets("P").Range("D8").Select End If If Sheets("P").Range("I8") = "عدد" Then Sheets("P").Range("$I$9:$J$208").Select With Selection.Font Selection.HorizontalAlignment = xlCenter Selection.NumberFormat = "General" Sheets("P").Range("$I$8:$K$208").Select Selection.Columns.AutoFit Sheets("P").Range("$K$8").Select Selection.Columns.Hidden = True End With Sheets("P").Range("D8").Select End If Sheets("مؤشر الفائدة").Select Application.ScreenUpdating = Fals ActiveSheet.Shapes.Range(Array("مستطيل 10")).Select Application.ScreenUpdating = False If Selection.Text = "إخفاء الأعمدة" Then With Selection Selection.Text = "إظهار الأعمدة" .Font.Color = -4072739 .ShapeRange.Fill.ForeColor.RGB = _ RGB(15, 15, 15) .ShapeRange.Line.ForeColor.RGB = _ RGB(169, 158, 103) End With End If End If Sheets("مؤشر الفائدة").Range("I7").Select End If End Sub

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