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

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

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

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