سليم حاصبيا

جرب هذا الماكرو اذا وجدت اي خلية اصغر من صفر يقوم الكود بتحديدها لاصلاحها Dim Rg As Range Dim cel As Range, first_ad$, Other_Ad$ Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False Range("B1:D20").Interior.ColorIndex = 6 If Not Intersect(Target, Range("B1:D20")) Is Nothing _ And Target.Count = 1 Then Set Rg = Range("B1:D20").Find("-", lookat:=2) If Not Rg Is Nothing Then first_ad = Rg.Address: Other_Ad = first_ad Do Rg.Interior.ColorIndex = 50 Set Rg = Range("B1:D20").FindNext(Rg) Other_Ad = Rg.Address If Other_Ad = first_ad Then Exit Do Loop End If Else For Each cel In Range("B1:D20") If cel < 0 Then cel.Interior.ColorIndex = 50 Next End If Application.EnableEvents = True End Sub الملف مرفق MY_code.xlsm

لا يمكن ادراج اي معادلة على صورة ولا يمكن لاحد ان يقوم بإنشاء ملف كما تريده (ربما يكون صحيحاً و في اغلب الأحيان لا عدا عن اضاعة الوقت في ذلك) لذلك ارفع الملف نفسه وليس صورة عنه لمحاولة معالجة الأمر

1-لا تجعل الخلية L1 فارغة ولا تحتوي على اسم اي شيت 2-اذا كان النطاق من L2 و نزولاً فارغاً الكود يأخذ كل الصفحات وإلا الصفحات المحددة في هذا النطاق 3-عدم ترك خلايا فارغة بين اسماء الشيتات المطلوبة في العامود L تفضل الكود المطلوب Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False fil_data_val Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro% 'first found row Dim ACT_Ro% 'Actual row All Others found rows Dim m%: m = 4 Dim My_rg As Range 'find range with Criteria in cell(A2) Dim Mon_Array SH.Range("A4:F" & Rows.Count).Clear Set Principal = Sheets("serch") Mon_Array = Application.Transpose(Range("L2", Range("L1").End(4))) If UBound(Mon_Array) > Sheets.Count Then For Each SH In Sheets If SH.Name = Principal.Name Then GoTo Next_sh Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh Ro = My_rg.Row: ACT_Ro = Ro Do Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(ACT_Ro, 1).Resize(, 5).Value Principal.Cells(m, 6) = SH.Name m = m + 1 Set My_rg = SH.Range("C:C").FindNext(My_rg) ACT_Ro = My_rg.Row If ACT_Ro = Ro Then Exit Do Loop Next_sh: Next Else '================================================ For Each SH In Sheets If SH.Name = Principal.Name Then GoTo Next_sh1 If Application.CountIf(Principal.Range("L2:L50"), SH.Name) <> 0 Then Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh1 Ro = My_rg.Row: ACT_Ro = Ro Do Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(ACT_Ro, 1).Resize(, 5).Value Principal.Cells(m, 6) = SH.Name m = m + 1 Set My_rg = SH.Range("C:C").FindNext(My_rg) ACT_Ro = My_rg.Row If ACT_Ro = Ro Then Exit Do Loop End If Next_sh1: Next '==================================== End If If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:F" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 24 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub '++++++++++++++++++++++++++++ Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i% Set S = Sheets("serch") Set dic = CreateObject("Scripting.Dictionary") For Each T In Sheets If T.Name = S.Name Then GoTo Next_T i = 2 Do Until T.Range("c" & i) = vbNullString dic(T.Range("C" & i).Value) = vbNullString i = i + 1 Loop Next_T: Next T With S.Range("A2").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing Set T = Nothing: Set S = Nothing End Sub الملف مرفق Saerch_by_Special_sheets.xlsm

في هذاه الحالة يلزم هذا الكود Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False fil_data_val Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro% 'first found row Dim Ro_Atc% 'All Others found rows Dim m%: m = 4 Dim My_rg As Range 'find range with Criteria in cell(A2) SH.Range("A4:E" & Rows.Count).Clear Set Principal = Sheets("serch") For Each SH In Sheets If SH.Name <> Principal.Name Then Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh Ro = My_rg.Row: Ro_Atc = Ro Do Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(Ro_Atc, 1).Resize(, 5).Value m = m + 1 Set My_rg = SH.Range("C:C").FindNext(My_rg) Ro_Atc = My_rg.Row If Ro_Atc = Ro Then Exit Do Loop End If Next_sh: Next If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:E" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 24 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub '++++++++++++++++++++++++++++ Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i% Set S = Sheets("serch") Set dic = CreateObject("Scripting.Dictionary") For Each T In Sheets If T.Name = S.Name Then GoTo Next_T i = 2 Do Until T.Range("c" & i) = vbNullString dic(T.Range("C" & i).Value) = vbNullString i = i + 1 Loop Next_T: Next T With S.Range("A2").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing Set T = Nothing: Set S = Nothing End Sub الملف مرفق Search_Account _repetitions.xlsm

يمكن ذلك لكن عليك وضع القائمة المنسدلة بعيداً عن الجدول (العامود A والعامود V لا يصلحان لانهما ملاصقان للجدول انا اخترت العامود X ) كما ذكرت لك ( دون تدخل خلايا غير فارغة على كل حدود الجدول) الماكرو: Sub MY_Test_CHOOS_FILTER() Dim ws As Worksheet Dim sh As Worksheet Dim lr As Long Set ws = Sheets("DATA") Set sh = Sheets("AS") With Application .Calculation = xlCalculationManual .ScreenUpdating = True End With On Error Resume Next With sh .Range("B2:U1026").Clear ws.Range("B7:U1026").Copy .Range("B2").PasteSpecial xlPasteValues .Columns(5).Replace 0, "" .Columns(5).SpecialCells(4).EntireRow.Delete .Range("B1").CurrentRegion.Sort _ Key1:=sh.Range(Range("X1")), Order1:=1, Header:=1 .Range("M:L").NumberFormat = "d/m/yyyy" End With On Error GoTo 0 With Application .CutCopyMode = False .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Range("B3").CurrentRegion.Borders.Value = 1 Range("B3").CurrentRegion.Offset(1).InsertIndent 1 sh.Range("B1").Select End Sub الملف مرفق Extract_WITH_CHOOSEN_FILTER.xlsb

تم معالجة الامر بالتعديل على الكود كما يلي Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False fil_data_val Application.EnableEvents = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro%, m%: m = 4 Dim My_rg As Range SH.Range("A4:E" & Rows.Count).Clear Set Principal = Sheets("serch") For Each SH In Sheets If SH.Name <> Principal.Name Then Set My_rg = SH.Range("c:c").Find(Rg, lookat:=1) If My_rg Is Nothing Then GoTo Next_sh Ro = My_rg.Row If Ro > 0 Then Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(Ro, 1).Resize(, 5).Value m = m + 1 End If End If Next_sh: Next If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:E" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 24 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub '++++++++++++++++++++++++++++ Sub fil_data_val() Dim S As Worksheet, T As Worksheet Dim dic As Object Dim i% Set S = Sheets("serch") Set dic = CreateObject("Scripting.Dictionary") For Each T In Sheets If T.Name = S.Name Then GoTo Next_T i = 2 Do Until T.Range("c" & i) = vbNullString dic(T.Range("C" & i).Value) = vbNullString i = i + 1 Loop Next_T: Next T With S.Range("A2").Validation .Delete .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ",")) End With dic.RemoveAll: Set dic = Nothing Set T = Nothing: Set S = Nothing End Sub الملف من جديد Search_Account _new.xlsm

انا لم الاحظ اي شيء عشوائي

بعد اذن الاخ علي يمكن ايضاً استعمال هذه المعادلة =SUMPRODUCT(IF(FREQUENCY($D$5:$D$16,$D$5:$D$16),$D$5:$D$16))

للعمل بالكود يجب ام يكون الجدول مستقلاً (راس واحد دون تدخل خلايا غير فارغة على كل اطرافه) تم التعديل على تصميم الجدول في الصفحة AS بحيث يفهمه اكسل كجدول حقيقي الكود بعد تعديله Sub MY_Test() Dim ws As Worksheet Dim sh As Worksheet Dim lr As Long Set ws = Sheets("DATA") Set sh = Sheets("AS") With Application .Calculation = xlCalculationManual .ScreenUpdating = True End With On Error Resume Next With sh .Range("B2:U1026").Clear ws.Range("B7:U1026").Copy .Range("B2").PasteSpecial xlPasteValues .Columns(5).Replace 0, "" .Columns(5).SpecialCells(4).EntireRow.Delete .Range("B1").CurrentRegion.Sort _ Key1:=sh.Range("E1"), Order1:=1, Header:=1 .Range("M:L").NumberFormat = "d/m/yyyy" End With On Error GoTo 0 With Application .CutCopyMode = False .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Range("B3").CurrentRegion.Borders.Value = 1 Range("B3").CurrentRegion.Offset(1).InsertIndent 1 sh.Range("B1").Select End Sub الملف مرفق Extract_sans_vide.xlsb

كي تعمل معك القائمة المنسدلة غادر الصفحة وعد اليها مجدداً

المشكلة عندك ان بعض الصفوف تأخذ قيمة الصفر بسبب المعادلات عندها لا يعتتبرها اكسل فارغة جرب هذا الماكرو Option Explicit Sub my_code() Dim D As Worksheet, A As Worksheet Dim RGA As Range, RgD As Range Dim RA As Long, RD As Long Dim obj As Object, i% Dim m%, n%: n = 19 Dim k%: k = 0 Dim X Set D = Sheets("DATA"): Set A = Sheets("AS") Dim My_max: My_max = D.Cells(5, 3).CurrentRegion.Rows.Count + 4 Set obj = CreateObject("Scripting.Dictionary") Dim arr For i = 7 To My_max If Application.CountA(D.Range("C" & i).Resize(, n)) = n Then arr = Join(Application.Transpose(Application.Transpose(D.Range("c" & i).Resize(, n))), "*") obj.Add (k), arr k = k + 1 End If Next A.Range("B3").Resize(10000, 25).ClearContents For m = 1 To obj.Count A.Cells(m + 2, 2).Resize(1, n) = Split(obj.Item(m - 1), "*") Next End Sub

جرب هذا الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Call find_Please(Me, Range("a2")) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++ Sub find_Please(SH As Worksheet, Rg) Dim Principal As Worksheet Dim Ro%, m%: m = 4 SH.Range("A4:E" & Rows.Count).Clear Set Principal = Sheets("serch") For Each SH In Sheets If SH.Name <> Principal.Name Then On Error Resume Next Ro = SH.Range("c:c").Find(Rg, lookat:=1).Row On Error GoTo 0 If Ro > 0 Then Principal.Cells(m, 1).Resize(, 5).Value = _ SH.Cells(Ro, 1).Resize(, 5).Value m = m + 1 End If End If Next If m = 4 Then _ MsgBox "Current Account Not Found": Exit Sub With Principal.Range("A4:E" & m - 1) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .HorizontalAlignment = 2 .VerticalAlignment = 2 .Interior.ColorIndex = 24 .InsertIndent 1 End With End Sub الملف مرفق Search_Account.xlsm

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

جرب هذا الكود Option Explicit Sub my_code() Dim D As Worksheet, A As Worksheet Dim lr As Long Dim RGA As Range, RgD As Range Dim RA As Long, RD As Long Set D = Sheets("DATA"): Set RgD = D.Range("B5").CurrentRegion Set A = Sheets("AS"): Set RGA = A.Range("B1").CurrentRegion RA = RGA.Rows.Count: RD = RgD.Rows.Count Set RgD = RgD.Offset(2).Resize(RD - 2) Set RGA = RGA.Offset(2).Resize(RA - 2) RGA.Clear A.Range("B3").Resize(RgD.Rows.Count, RgD.Columns.Count).Value = _ RgD.Value A.Range("B1").CurrentRegion.Borders.LineStyle = 1 End Sub Tarhil.xlsb

نفس الملف بواسطة الماكرو اذا كنت تريد الماكرو Option Explicit Sub Plus_num() Range("H2").Copy Range(Range("A2"), Range("A2").End(4)). _ PasteSpecial , Operation:=2 Application.CutCopyMode = False Range("A2").Select End Sub '+++++++++++++++++++++++++++++++++++++++++ Sub Minus_num() Range("J2").Copy Range(Range("A2"), Range("A2").End(4)). _ PasteSpecial , Operation:=3 Application.CutCopyMode = False Range("A2").Select End Sub aa.xlsm

الدالة CEILING لا تقوم بهذا الشيء عليك استعمال هذه المعادلة =A2+1

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

و لكن لماذا عندما اضغط على الاسم . يمحو البياناات. في الجدول.؟؟؟ هذا لأنه اذا ضغطت على الاسم مرة ثانية يفهم الاكسل انك تريد ان تعدل بالبيانات لهذا الاسم لذلك يمحوها لك بانتظار ادخال بيانات جديدة عن نفس الاسم

لا لزوم لتكرار السؤال اكثر من مرة قلت لك تمت الاجابة اذهب الى هذا العنوان https://www.officena.net/ib/topic/99390-استفسار-بارك-الله-فيكم/

تمت الاجابة على هذا العنوان https://www.officena.net/ib/topic/99390-استفسار-بارك-الله-فيكم/

جرب هذا الملف Classeur_new.xlsm

لا حظ هذه الصورة واتبع الأرقام / 1 2 3 4

تم التصحيح مرة اخرى profabs_new1.xlsm

تم معالجة الامر profabs_new.xlsm

لا حاجة لكل هذا الازرار 1- حدد التاريخ 2-حدد حصص الغياب (بالضغط داخل مربع كل حصة للتبديل بين غائب وحاضر "غائب") 3 اضغط على الاسم My_Repport.xlsm