سرعة الكود

[samycalls2020]

السلام عليكم ورحمة الله وبركاته

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

 

[عبدالله بشير عبدالله]

وعليكم السلام ورحمة الله وبركاته

ارفق ملفا به بيانات لتتم تجربة اي كود معدل علية ومقارنته بالكود الاصلي من حيث السرعة وخصوصا لا نعلم حجم البيانات بالملف 

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

وكذلك بدل النسخ واللصق للقيم يتم النقل المباشر للقيم Value = .Value

فوجود الملف مهم للتجربة ولعمل افضل حل لطلبك

 

 

[samycalls2020]

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

شهادات.xlsb