سليم حاصبيا

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

جرب هذا الملف ( الصفحة Salim ) الكود Option Explicit Sub Salim_macro() Application.ScreenUpdating = False Dim lrB% lrB = Cells(Rows.Count, 2).End(3).Row Range("H5:K500").Clear Range("B5:E" & lrB).Copy With Range("H5") .PasteSpecial (12) .PasteSpecial (8) .PasteSpecial (xlPasteFormats) With .Offset(, 2).Resize(lrB - 4) .SpecialCells(4).Formula = "=J5" .Interior.ColorIndex = 6 End With .CurrentRegion.Borders.LineStyle = 1 .CurrentRegion.InsertIndent 1 End With Application.CutCopyMode = False Range("J5").Select Application.ScreenUpdating = True End Sub الملف مرفق Copy_my_data.xlsm

جرب هذا الكود Option Explicit Sub Get_Month() Dim rg As Range Dim x%, i% Set rg = Sheets("Monthly").Range("A7:A18") If Application.CountA(rg) = 12 Then rg.Value = "" End If For i = 0 To ListBox1.ListCount - 1 x = Application.CountA(rg) + 1 If x = 13 Then rg.Value = "" If ListBox1.Selected(i) Then rg.Cells(x) = ListBox1.List(i) x = x + 1 If x = 13 Then Exit Sub End If Next End End Sub '++++++++++++++++++++++++++++++++++++++++++ Private Sub ListBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ' 13 Enter key Get_Month End If End Sub الملف مرفق MY_Months.xlsm

في اي جدول اكسل لا يسمح بخلية واحدة فارغة وكيف يكون الامر بصفوف فارغة

لا أعلم اذا كان هذا المطلوب MY_Months.xlsx

تم التعديل على الكود ليعمل على طريقة (Find) Option Explicit Sub Salim_Code_With_Find_Methode() Dim S As Worksheet Dim La%, first_address Dim find_range As Range, Source_rg As Range Dim My_cel As Range, Opt_rg As Range 'Optional range Set S = Sheets("Sheet1") La = S.Cells(Rows.Count, 2).End(3).Row Set Source_rg = S.Range("B5:B" & La) Source_rg.Font.ColorIndex = vbBlack For Each My_cel In Source_rg My_cel = Abs(My_cel) Next With S.Range("B4:B" & La) Set find_range = .Find([f3], after:=Range("B" & La), lookat:=1) If Not find_range Is Nothing Then first_address = find_range.Address Do If Opt_rg Is Nothing Then Set Opt_rg = Range("B" & find_range.Row) Else Set Opt_rg = Union(Opt_rg, Range("B" & find_range.Row)) End If Set find_range = .FindNext(find_range) If first_address = find_range.Address Then Exit Do Loop End If End With If Not Opt_rg Is Nothing Then Opt_rg.Value = -Opt_rg.Value Opt_rg.Font.ColorIndex = 3 Else MsgBox "Your Value: " & [f3] & Chr(10) & " Is'nt Found" End If End Sub الملف مرفق Saerch_Please_Find.xlsm

TO FORM- TO SHEET ينقلان ما في الشيت الى الفورم وبالعكس بالضغط على الزر المناسب

جرب هذا الماكرو Option Explicit Sub salim_code() Dim s As Worksheet Dim La%, I%, Ro1, Ro2 Dim F_rg As Range, Source_rg As Range Dim My_number Set s = Sheets("Sheet1") La = s.Cells(Rows.Count, 2).End(3).Row Set Source_rg = s.Range("B4:B" & La) Source_rg.Font.ColorIndex = vbBlack My_number = Abs(s.Range("F3")) For I = 5 To La If IsNumeric(Cells(I, 2)) Then _ s.Cells(I, 2) = Abs(s.Cells(I, 2)) Next For I = 4 To La If s.Cells(I, 2) = My_number Then s.Cells(I, 2) = -s.Cells(I, 2) s.Cells(I, 2).Font.ColorIndex = 3 End If Next I End Sub الملف مرفق Saerch_Please.xlsm

بعذ اذن الاخ ارائد هذا الملف My_saerch.xlsx

جرب هذا الملف الكود Option Explicit Sub From_sheet_to_Form() With Sheets("Salim") If .Range("N6") = vbNullString Then Exit Sub .[P8] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,2,0)") .[N8] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,3,0)") .[P10] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,4,0)") .[N10] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,5,0)") .[Q12] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,6,0)") .[O12] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,7,0)") .[M12] = Evaluate("=VLOOKUP($N$6,$A$2:$J$100,8,0)") End With End Sub '+++++++++++++++++++++++++++++++++++++++ Sub add_to_data_val() Dim arr(), m%, i%, lr% Dim s As Worksheet Set s = Sheets("Salim") lr = s.Cells(Rows.Count, 1).End(3).Row i = 2: m = 1 Do Until i = lr + 1 If Application.CountIf(s.Range("A2:A" & i), s.Range("A" & i)) = 1 Then ReDim Preserve arr(1 To m) arr(m) = s.Range("A" & i) m = m + 1 End If i = i + 1 Loop ReDim Preserve arr(1 To m) arr(m) = s.Range("N6") With s.Range("N6").Validation .Delete .Add 3, Formula1:=Join(arr, ",") End With s.Range("A" & lr + 1) = arr(UBound(arr)) s.Range("N6") = arr(UBound(arr)) End Sub '++++++++++++++++++++++++++++++++++++++++++++ Sub Form_To_sheet() Dim s As Worksheet Dim rg As Range, RO% Dim lr%, Answer As Byte Set s = Sheets("Salim") lr = s.Cells(Rows.Count, 1).End(3).Row If Application.CountIf(s.Range("A2:A" & lr), s.Range("N6")) = 0 Then Answer = MsgBox("This code dosn't exixts!.. " & Chr(10) & _ "Do you like to add it", 4) If Answer = 6 Then add_to_data_val Exit Sub End If End If Set rg = s.Range("A1:A" & lr).Find(s.[N6], lookat:=1) If rg Is Nothing Then Exit Sub RO = rg.Row With s .Range("A" & RO) = .[N6]: .Range("B" & RO) = .[P8] .Range("C" & RO) = .[N8]: .Range("D" & RO) = .[P10] .Range("E" & RO) = .[N10]: .Range("G" & RO) = .[Q12] .Range("H" & RO) = .[O12]: .Range("I" & RO) = .[M12] End With End Sub الملف مرفق Vice_versa.xlsm

ممكن ان يكون الماكرو المطلوب Option Explicit Sub Salim_Code() Dim Sh As Worksheet Dim Add1$, Add2$ Dim FRg As Range Dim m%, ro%, i%, x%, y% Set Sh = Sheets("Sheet1") Sh.Range("G2:P100").Clear ro = Sh.Cells(Rows.Count, 2).End(3).Row m = 7 For i = 2 To ro Set FRg = Sh.Range("D1:D" & ro).Find(Sh.Cells(i, 1), lookat:=1) If Not FRg Is Nothing Then Add1 = FRg.Row: Add2 = Add1 Do Cells(i, m) = Cells(Add2, 2) Cells(i, m + 1) = Cells(Add2, 3) Set FRg = Sh.Range("D1:D" & ro).FindNext(FRg) Add2 = FRg.Row m = m + 2 Loop Until Add2 = Add1 End If m = 7 Next x = Sh.Cells(Rows.Count, "G").End(3).Row For i = 2 To x If Sh.Cells(i, "G") <> vbNullString Then y = Application.CountA(Sh.Cells(i, "G").Resize(, 10)) With Sh.Cells(i, "G").Resize(, y) .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14: .Font.Bold = True .Interior.ColorIndex = 35 End With End If Next End Sub الملف مرفق My_Employ.xlsm

كيف لي ان أحدد من هو القائد في العامود B كيف أعرف المزظفين التابعين له (هل يا ترى من خلال لون الخلية التي على يساره؟ ام ماذا؟)

اليس هذا ما تريده

و هذا ما يفعله الماكرو بالضبط

جرب هذا الماكرو Option Explicit Sub Farz() Dim Sh As Worksheet Dim col As New Collection Dim arr(), x%, m%, ro%, i%, y% Set Sh = Sheets("Sheet1") ro = Sh.Cells(Rows.Count, 2).End(3).Row With Sh .Range("F3").CurrentRegion.Clear For i = 2 To ro On Error Resume Next If .Cells(i, 4) <> vbNullString Then col.Add .Cells(i, 4).Value, CStr(.Cells(i, 4).Value) End If Next On Error GoTo 0 m = 3: y = 7 If col.Count Then For i = 1 To col.Count .Cells(m, y - 1) = col(i) For x = 2 To ro If .Cells(x, 4) = col(i) Then .Cells(m, y) = .Cells(x, 2) .Cells(m, y + 1) = .Cells(x, 3) y = y + 2 End If Next m = m + 1: y = 7 Next End If End With If Sh.Cells(3, "F") <> vbNullString Then With Sh.Range("F3").CurrentRegion .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14: .Font.Bold = True .Interior.ColorIndex = 40 .Sort key1:=.Cells(1, 1), Header:=2 End With End If Set col = Nothing End Sub الملف مرفق Common_Employ.xlsm

هذه المعادلة (Ctrl+Shift+Enter) =CHOOSE((OR(E$1="الكل",F$1="All")+1),IF(ROWS($B$4:B4)>SUMPRODUCT(--(Data!$R$2:$R$200&Data!$S$2:$S$200=E$1&F$1)),"",INDEX(Data!$D$2:$D$200,SMALL(IF(Data!$D$2:$D$200<>"",IF(Data!$R$2:$R$200&Data!$S$2:$S$200=E$1&F$1,ROW(Data!$D$2:$D$200)-ROW(Data!$D$2)+1)),ROWS($B$4:B4)))),Data!D2) الملف مرفق Cond_filter3.xlsx

هذه المعادلة (Ctrl+Shift+Enter) ولا حاجة الى (IFERROR) =IF(E$1="الكل",Data!D2,IF(ROWS($B$4:B4)>COUNTIF(Data!$R$2:$R$200,E$1),"",INDEX(Data!$D$2:$D$200,SMALL(IF(Data!$D$2:$D$200<>"", IF(Data!$R$2:$R$200=E$1, ROW(Data!$D$2:$D$200)-ROW(Data!$D$2)+1)),ROWS($B$4:B4))))) الملف مرفق Cond_filter.xlsx

هذا الكود البسيط Sub Show_all() Sheets("Sheet1").Rows.Hidden = False End Sub

1- تبديل اسماء الصفحات الى Source و Targ لجسن نسخ الكود ولصقه الكود Option Explicit Sub get_data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim s As Worksheet, T As Worksheet Dim S_rg As Range, Find_rg As Range Dim Nme$, i% Dim RoT%, Ro%, m%: m = 3 Set s = Sheets("source"): Set T = Sheets("Targ") Nme = T.Cells(1, 1) RoT = T.Cells(Rows.Count, 1).End(3).Row T.Range("A3").Resize(RoT, 3).Clear If Nme = vbNullString Then GoTo End_Me Set Find_rg = s.Columns("M").Find(Nme, lookat:=1) If Not Find_rg Is Nothing Then Ro = Find_rg.Row + 2 Set S_rg = s.Cells(Ro, 1).CurrentRegion For i = 1 To 10 Step 3 S_rg.Cells(1, i).Resize(S_rg.Rows.Count, 3).Copy _ T.Cells(m, 1) m = m + S_rg.Rows.Count Next End If If m > 3 Then With T.Range("A3").CurrentRegion .InsertIndent 1 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .Interior.ColorIndex = 35 End With End If End_Me: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With End Sub الملف مرفق Basma Sh.xlsm

جرب هذا الملف Special_sum.xlsx

اخر ما يمكنني عمله Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo") Select Case R.Range("F2") Case "الموردين": Set A = Sheets("Achat") Case "العملاء": Set A = Sheets("Mabi3at") Case Else: GoTo End_Me End Select Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "C") = _ IIf(IsDate(K.Cells(Actrow, "C")), K.Cells(Actrow, "C"), "") R.Cells(m, "K") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), "") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With R.Range("A8").CurrentRegion.Columns(3).NumberFormat = "[$-ar-LB] dddd d mmmm yyyy" R.Range("A8").CurrentRegion.Sort key1:=R.Cells(1, 3), Header:=1 End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف للمرة الخامسة و الأخيرة SAL_My_data_5.xlsm

مع اني لا أحب التغامل مع اليوزرفورم اليك هذا الملف Private Sub CommandButton1_Click() Sheets("Sheet1").Rows.Hidden = False Sheets("Sheet1").Cells(2, "H").Resize(, 2) = "" If Me.TextBox1 = "" Or Me.TextBox2 = "" Then Exit Sub Dim Mx As Date, Mn As Date Mx = Application.Max(Me.TextBox1, Me.TextBox2) Mn = Application.Min(Me.TextBox1, Me.TextBox2) Dim I%, Ro% Ro = Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row Sheets("Sheet1").Cells(3, 1).Resize(Ro).Rows.Hidden = True For I = 3 To Ro If CDate(Sheets("Sheet1").Cells(I, 2)) >= Mn And _ CDate(Sheets("Sheet1").Cells(I, 2)) <= Mx Then _ Sheets("Sheet1").Cells(I, 1).EntireRow.Hidden = False Next Sheets("Sheet1").Cells(2, "H") = Mn Sheets("Sheet1").Cells(2, "I") = Mx: Unload Me End Sub الملف مرفق filter-date_Sal.xlsm

بعد اذن الاخ رائد هذا الملف تم حماية العادلات لعدم التلاعب بها غن طريق الخطأ My_Book5.xlsx

تم معالجة الامر Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "C") = _ IIf(IsDate(K.Cells(Actrow, "C")), K.Cells(Actrow, "C"), "") R.Cells(m, "K") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), "") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 '++++++++++++++++++++++++++++++++++++++++++ ' R.Cells(ALLROW, "K") = "المجموع" ' R.Cells(ALLROW, "L") = _ ' Evaluate("=SUM(L9:L" & ALLROW - 1 & ")") '++++++++++++++++++++++++++++++++++++++++++ End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With R.Range("A8").CurrentRegion.Columns(3).NumberFormat = "[$-ar-LB] dddd d mmmm yyyy" R.Range("A8").CurrentRegion.Sort key1:=R.Cells(1, 3), Header:=1 End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف الرابع مرفق SAL_My_data_4.xlsm

تم التعديل Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "k") = _ IIf(IsDate(K.Cells(Actrow, "C")), K.Cells(Actrow, "C"), "") R.Cells(m, "k").NumberFormat = "[$-ar-LB] dddd d mmmm yyyy" R.Cells(m, "L") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), "") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 '++++++++++++++++++++++++++++++++++++++++++ R.Cells(ALLROW, "K") = "المجموع" R.Cells(ALLROW, "L") = _ Evaluate("=SUM(L9:L" & ALLROW - 1 & ")") '++++++++++++++++++++++++++++++++++++++++++ End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف مرفق SAL_My_data_3.xlsm