سليم حاصبيا

ريما يكون هذا الكود هو المطلوب Private Sub UserForm_Initialize() Dim K%: K = Sheets("ورقة1").Cells(6, Columns.Count).End(1).Column Dim i% On Error Resume Next For i = 1 To K Me.Controls("Lb" & i).Caption = Cells(6, i).Value Next i End Sub

جرب هذا االملف الكود Sub crazy_sum() Dim arr() Dim i% For i = 1 To Sheets.Count ReDim Preserve arr(1 To i) arr(i) = Sheets(i).Name Next On Error Resume Next With Sheets("Sheet1") .Range("a1") = IIf(IsError(Application.Match(CStr(.Range("a2") + _ .Range("a3")), arr, 0)), Evaluate("=sum(a2:a3)"), vbNullString) End With End Sub الملف مرفق Crezy_Book.xlsm

الكود الذي وضعته لا يفي بالغرض تماماً لذلك قمت بتعديل الكود كما تريد ليأخذ بياناتة من الصفحة Preparation تم اضافة ميزة مهمة انه لا يسمح بتكرار نفس الاسم بذات التاريخ SHEIT salim _new.xlsm

يمكن ان يكون المطلوب Salim Worksheet.xlsx

ارفع مثالاً ما تريد

الحل هنا الكود Option Explicit Sub salim_rows() Dim t% Dim lr% Dim my_rg As Range Application.ScreenUpdating = False If ActiveSheet.Name <> "المدرسة " Then GoTo End_Me lr = Cells(Rows.Count, 1).End(3).Row On Error Resume Next Set my_rg = Range("a4:m" & lr).SpecialCells(4) my_rg.EntireRow.Delete On Error GoTo 0 t = 6 Do Until Cells(t, "A") = "" Rows(t).Insert t = t + 2 Loop End_Me: Application.ScreenUpdating = True End Sub الملف مرفق أسماء العاملين 2017 salim.xlsm

جرب هذا الملف SHEIT salim.xlsm

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

الكود التلقائي Private Sub Worksheet_Change(ByVal Target As Range) Dim i%: i = 6 Dim My_rg As Range Set My_rg = Union(Range("d6").CurrentRegion, Range("f6").CurrentRegion) Application.EnableEvents = False If Not Intersect(Target, My_rg) Is Nothing And Target.Cells.Count = 1 Then Do Until Cells(i, 4) = vbNullString If Int(Cells(i, 4)) = Cells(i, 6) Then _ Cells(i, 4).Value = Int(Cells(i, 4).Value) i = i + 1 Loop End If Application.EnableEvents = True End Sub

Option Explicit Sub fixe_date() Dim i%: i = 6 Do Until Cells(i, 4) = vbNullString If Int(Cells(i, 4)) = Cells(i, 6) Then _ Cells(i, 4).Value = Int(Cells(i, 4).Value) i = i + 1 Loop End Sub يعد اذن اخي شوقي هذا الكود الملف مرفق تحويل معادلة التاريخ الى ناريخ عادى بشرط salim.xlsm

الملف بدون حماية جلب بيانات salim without Protection.xlsx

زيادة في اثراء الموضوع هذا الملف جلب بيانات salim1.xlsx

التعديل جلب بيانات salim.xlsx

تم التعديل على الكود ليعمل كما تشاء new_spec_Salim_With _Numaretion.xlsm

جرب هذا الملف جلب بيانات من قائمة منسدلة بشرط salim.xlsx

بالنسية للسؤال الاول استبدل الماكرو بهذا Option Explicit Option Base 1 Sub filter_for_ME() Dim y%, t%, i%, match%, r%: r = 3 Dim S_sh As Worksheet: Set S_sh = Sheets("BD") Dim T_sh As Worksheet: Set T_sh = Sheets("نتيجة") Dim My_Table As Range: Set My_Table = S_sh.Range("a1").CurrentRegion Dim arr(), n_Rows%: n_Rows = My_Table.Rows.Count Dim k%, a%, Arr_Num%: Arr_Num = 1 Dim ar_ad() Dim tt$ Dim Saerch_Rg As Range Dim my_col% T_sh.Range("a3:g1000").Clear ar_ad = Array("=$A2", "=$B2", "=$C2", "=$D2", "=$E2", "=$F2", "=$G2") match = Application.match(T_sh.[d1], S_sh.Rows(1), 0) Application.ScreenUpdating = False S_sh.Activate '==================================== For k = 2 To n_Rows If Cells(k, match) = vbNullString Then Cells(k, match) = "(EMPTY)" Next For k = 2 To n_Rows y = Application.CountIf(S_sh.Range(Cells(1, match), Cells(k, match)), S_sh.Cells(k, match)) If y = 1 Then ReDim Preserve arr(1 To Arr_Num): _ arr(Arr_Num) = S_sh.Cells(k, match): Arr_Num = Arr_Num + 1 Next T_sh.Activate '========================================= For k = 1 To UBound(arr) T_sh.Range("E1") = arr(k) tt = Application.Index(ar_ad, match) & "=" & T_sh.Name & "!$E$1" T_sh.Range("m2") = tt My_Table.AdvancedFilter Action:=2, criteriarange:=T_sh.Range("m1:m2"), _ copytorange:=T_sh.Range("a" & r) t = T_sh.Cells(Rows.Count, 1).End(3).Row r = t + 2 Next For k = 2 To n_Rows If S_sh.Cells(k, match) = "(EMPTY)" Then S_sh.Cells(k, match) = vbNullString Next With Range("a3:G" & r - 2).SpecialCells(2, 23) .Borders.LineStyle = 1 .InsertIndent 1 End With Set Saerch_Rg = T_sh.Range("a3:G" & r - 2).Find("(EMPTY)") If Not Saerch_Rg Is Nothing Then my_col = Saerch_Rg.Column For a = 4 To r - 2 If T_sh.Cells(a, my_col) = "(EMPTY)" Then T_sh.Cells(a, my_col) = vbNullString End If Next End If T_sh.Range("e1").Clear: T_sh.Range("m1:m2").Clear Erase arr: Erase ar_ad: Set Saerch_Rg = Nothing Application.ScreenUpdating = True End Sub اما السؤال الثاني لم افهم المطلوب الملف من جديد new_spec_filter.xlsm

اليك هذا الماكرو الذي يدرج لك 4 معادلات قي كافة الصفجات كل واحدة في مكانها المناسب لا وقت لدي لتكملته (تستطيع انت فعل ذلك بنفس الطريقة) الماكرو Option Explicit Sub Salim_Macro() 'هذا الماكرو يدرج 4 معادلات تسطيع ان تكمله لادراج كافة المعادلات Dim Y$ Dim x%, i%, K%: K = Sheets.Count For i = 2 To K x = Sheets(i).Index '===================== fromula in D5========== Y = "='0'!B" & x + 2 Sheets(i).Range("d5") = Evaluate(Y) '===================== fromula in d8========== Y = "=IF('0'!C" & x + 2 & ",'0'!C" & x + 2 & ","""" )" Sheets(i).Range("d8") = Evaluate(Y) '===================== fromula in F10========== Y = "=IF('0'!D" & x + 2 & ",'0'!D" & x + 2 & ","""" )" Sheets(i).Range("f10") = Evaluate(Y) '===================== fromula in M10========== Y = "=IF('0'!E" & x + 2 & ",'0'!E" & x + 2 & ","""" )" Sheets(i).Range("M10") = Evaluate(Y) Next End Sub الملف مرفق اضغط فقط على الزر RUN في الصفجة 0 B6_salim.xls

قم بتنشيط كل الصفحات دفعة واحدة و ذلك حسب الخطوات التالية: 1 اضغط بشكل متواصل على Ctrl , واختر الصفحات المطلوبة واحدة بعد الاخرى يواسطة نقر الماوس على اسمها 2 اترك الزر Ctrl 3 اكتب المعادلة المطلوبة (يمكنك سحب المعادلة الى اكثر من صف او عامود) و هكذا نكتب المعادلة في كل الصفحات لالغاء تحديد مجموعة الصفحات قم بالضفط على صفحة ليست في هذ المجموعة شاهد هذا الفيديو

ممتاز !.....و قد سبق لي ان عملت شيئأً بهذا الخصوص انظر المرفق Add_Hyper to all_sheets.xlsm

يجب قبل التصفية ازالة الحماية ثم التصفية ثم اعادة الحماية Sub Macro1() ActiveSheet.Unprotect Password:="abdo4" ActiveSheet.ListObjects("الجدول1").Range.AutoFilter Field:=1, Criteria1:= _ "أكبر" ActiveSheet.Protect Password:="abdo4" End Sub '============================================= Sub Macro2() ActiveSheet.Unprotect Password:="abdo4" ActiveSheet.ListObjects("الجدول1").Range.AutoFilter Field:=1, Criteria1:= _ "أقل" ActiveSheet.Protect Password:="abdo4" End Sub

جرب الان التصفية Salim.xlsm

the file is protecd by password

لك ما تريد Salim_Abu_Amr.xlsx

انظر الى هذا الملف SHEIT salim.xlsx

تم النعديل على الملف من اجل اختيار بأي عامود تتم التصفية(تاريخ الميلاد / الوظيفة/ مكان الميلاد الخ...) فقط اختر العامود المناسب من الخلية E1 و اضغط الزر Give_Me_ Data_Please spec.filter_2010.xlsm