ابا اسماعيل

جريب هذا الكود
 
Sub FasterMacro() Dim wsSource As Worksheet Dim wsCriteria As Worksheet Dim wsExtract As Worksheet Dim sourceRange As Range Dim criteriaRange As Range Dim extractRange As Range ' تحديد ورقة المصدر Set wsSource = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير "Sheet1" إلى اسم ورقتك ' تحديد ورقة المعايير Set wsCriteria = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر ' تحديد ورقة الاستخراج Set wsExtract = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر ' تحديد نطاق البيانات المصدر Set sourceRange = wsSource.Range("AM:BD") ' تحديد نطاق المعايير Set criteriaRange = wsCriteria.Range("'Criteria'") ' تحديد نطاق الاستخراج Set extractRange = wsExtract.Range("'Extract'") ' تطبيق تصفية متقدمة sourceRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=criteriaRange, CopyToRange:=extractRange, Unique:=False ' تحديد نطاق آخر (يمكن تعديله وفقًا لاحتياجاتك) wsSource.Range("DC3:DT3").Select End Sub  

تفظل جريب هذا الكود
 
Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim cell As Range Set ws = ThisWorkbook.Sheets("Sheet1") If Not Intersect(Target, ws.Columns("A")) Is Nothing Then Application.EnableEvents = False For Each cell In Target If cell.Value <> "" Then Dim charCount As Long charCount = Len(cell.Value) - Len(Replace(cell.Value, " ", "")) Dim fontSize As Long fontSize = 14 - charCount If fontSize < 8 Then fontSize = 8 End If cell.Font.Size = fontSize End If Next cell Application.EnableEvents = True End If End Sub