سليم حاصبيا

قم باخفاء الصف رقم 5 (حتى لا يكتب فيه اي شيء عن طريق الخطأ وتقع في نفس المشكلة السّابقة)

فقط اجعل الصف الذي قبل بداية عناوين الجدول فارغاً تم رفع ملف جديد في اخر مشاركة من قبلي (نسخة عن الملف الذي رفعته انت مع تعدبل الماكرو )

الملف يحنوي على خلايا مدمجة كتت قد حذرت من ذلك مسبقاً (ولا حياة لمن تنادي) لذلك ادرج صفاً فارغا (كما في الصورة الصف رقم5) حتى يتخلص الجدول من هذه الخلايا المدمجة (تم ادراجه) وهناك صفحات لا علاقة لها بالأمر مثل "Form1" و "Form2" الخ...يجب استثناء هذه الصفحات من عمل الماكرو بوضعها في Array أسميته (array_sheet) ليتم تجاهلها من جانب الماكرو ( الدالة Check_Up ) و كلما اضفت صفحة لا علاقة لها بالماكرو يحب وضع اسمها في هذا الــ Array الماكرو المطلوب (بعد ادراج صف فارغ رقم 5 في الصفحة "تسجيل_الموظفين") Option Explicit Dim I%, LR% Dim t As Worksheet Dim Spes_sh As Worksheet Dim Flter_rg As Range Dim RO% Dim array_sheet() Dim Check_Up As Boolean Sub ADD_Sheets() Set t = Sheets("تسجيل_الموظفين") LR = t.Cells(Rows.Count, 2).End(3).Row If LR < 7 Then Exit Sub With t For I = 7 To LR If Not Application.Evaluate("ISREF('" & _ .Range("B" & I) & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = _ .Range("B" & I) End If Next End With End Sub '+++++++++++++++++++++++++++ Sub transfer_data() Application.ScreenUpdating = False ADD_Sheets array_sheet = Array("Form1", "Form2", "Pictures", _ "تسجيل_الموظفين", "البيانات الرئيسية") Set t = Sheets("تسجيل_الموظفين") t.Select Set Flter_rg = t.Range("A6").CurrentRegion For Each Spes_sh In Sheets Check_Up = IsError(Application.Match(Spes_sh.Name, array_sheet, 0)) If Check_Up Then Spes_sh.Range("A6").CurrentRegion.Clear Flter_rg.AutoFilter 2, Spes_sh.Name Flter_rg.SpecialCells(12).Copy With Spes_sh.Range("A6") .PasteSpecial (8) .PasteSpecial (12) .PasteSpecial (4) End With RO = Spes_sh.Cells(Rows.Count, 1).End(3).Row If RO > 6 Then Spes_sh.Range("A7").Resize(RO - 6).Value = _ Evaluate("Row(1:" & RO - 6 & ")") End If End If Next Spes_sh t.AutoFilterMode = False t.Select With Application .ScreenUpdating = True .CutCopyMode = False End With End Sub Hatem_Extra.xlsm

الورقة محمية بكلمة سر بجب ازالة الجماية عنها أو اضف الى الكود هذين السطرين في المكان المناسب (لفك الجمابة ثم اعادتها اوتوماتيكياً) (تضع مكان abcd كلمة السر الخاصة بالشيت)

الحل Hani.xls

اخي ابراهيم معادلات رائعة لكن للاسف في جال تكرار الــ Max تظهر نتيجة واحدة ( كما في الصورة) جرب ان تظهر كل النتائج

بمكن الاستغناء غن اليوزر الثاني بهذا الكود 1- عند الضغط غلى الزر تظهر لك رسالة تطلب الكمية (اذا ادخلت بالخطأ نصاُ يبوفف الكود ويطلب عدداً) 2- بعد ادخال العدد المطلوب يقوم الكود بادخال البيانات مع المعادلة المطلوبة الكود Private Sub CmdAdd_Click() If Me.ListFind.ListCount = 0 _ Or Me.ListFind.ListIndex < 1 Then Exit Sub Dim arr() Dim sh As Worksheet Dim Ro%, m%, x%, Y% Set sh = Sheets("فاتورة") Ro = sh.Cells(Rows.Count, "c").End(3).Row If Ro < 10 Then Ro = 9 Ro = Ro + 1 If Ro > 60 Then sh.Range("c10:H60").ClearContents Ro = 10 End If x = Me.ListFind.ListIndex Y = Application.InputBox("tYPE NUMBER", "CHOOSE ONLY NUMBERS", 1, Type:=2) With sh.Cells(Ro, 3) .Value = Val(.Offset(-1)) + 1 .Offset(, 1) = Me.ListFind.List(x, 2) .Offset(, 2) = Me.ListFind.List(x, 3) .Offset(, 3) = Y .Offset(, 4) = Me.ListFind.List(x, 4) End With With sh.Range("h10:h" & Ro) .Formula = "=IF(E10="""","""",PRODUCT(F10:G10))" .Value = .Value End With TextFind_Change End Sub '+++++++++++++++++++++++++++++++++ Private Sub TextFind_Change() ListFind.Clear Dim k#: k = 0 Dim t# Dim laste_row# Dim All_Rg As Range 'Range when we saecrh Dim Fd_Rg As Range 'Range to find Dim F_row#, A_row# 'First row by saerch,Actual row by saerch With Me.ListFind .AddItem "تسلسل" .List(.ListCount - 1, 1) = "رقم الصف" For k = 2 To .ColumnCount .List(.ListCount - 1, k) = Sheets("البيانات").Cells(1, k - 1) Next End With k = 1 With Sheets("البيانات") laste_row = .Cells(Rows.Count, 2).End(3).Row Set All_Rg = .Range("B2:B" & laste_row) Set Fd_Rg = All_Rg.Find(Left(TextFind.Value, Len(TextFind.Value)), lookat:=2) If Not Fd_Rg Is Nothing Then F_row = Fd_Rg.Row: A_row = F_row Do If Left(Fd_Rg, Len(TextFind.Value)) = _ TextFind.Value Then Me.ListFind.AddItem Me.ListFind.List(Me.ListFind.ListCount - 1, 0) = k Me.ListFind.List(Me.ListFind.ListCount - 1, 1) = F_row Me.ListFind.List(Me.ListFind.ListCount - 1, 2) = _ .Cells(F_row, 1) Me.ListFind.List(Me.ListFind.ListCount - 1, 3) = _ .Cells(F_row, 2) Me.ListFind.List(Me.ListFind.ListCount - 1, 4) = _ .Cells(F_row, 3) Me.ListFind.List(Me.ListFind.ListCount - 1, 5) = _ .Cells(F_row, 4) k = k + 1 End If Set Fd_Rg = All_Rg.FindNext(Fd_Rg) F_row = Fd_Rg.Row If F_row = A_row Then Exit Do Loop End If End With If Me.ListFind.ListCount = 1 Then Me.ListFind.Clear End If End Sub الملف مرفق ismail_NEW.xlsm

عذراً انا لا أعمل في مجال اليوزر وطريقة ترابط 2 يوزر مع بعض لان خبرتي في هذا المجال بسيطة

للمرة 100 بعد الالف (عدم ادراج ضفوف كثيرة جداً حوالي 3000 صف ) مثال بسيط من 10 الى 15 صف تكفي الملف كيف يجب ان يبدو في دون الوان فاقعة الصورة يمكن ان تعدل في الكود اذا كان هناك احطاء لاني كنبته على وجه السرعة الكود Private Sub CommandButton1_Click() Dim sh As Worksheet Dim i%, BoL1 As Boolean, BoL2 As Boolean Dim AR_T() Dim AR_C() AR_T = Array(1, 2, 3, 4, 5, 6) AR_C = AR_T For i = 0 To 5 If Me.Controls("TextBox" & AR_T(i)) = "" Then BoL1 = True Exit For End If Next For i = 0 To 5 If Me.Controls("ComboBox" & AR_C(i)) = "" Then BoL2 = True Exit For End If Next If BoL1 Or BoL2 Then MsgBox Prompt:="يجب إكمال كافة البيانات", Title:="خطأ" Exit Sub End If Set sh = Sheets("data") Dim EndRow As Long EndRow = sh.Cells(Rows.Count, "b").End(3).Row + 1 With sh.Cells(EndRow, 1) .Value = EndRow - 1 .Offset(, 1) = TextBox1.Value 'OK .Offset(, 2) = TextBox2.Value .Offset(, 4) = ComboBox1.Value .Offset(, 9) = ComboBox3.Value .Offset(, 10) = ComboBox2.Value .Offset(, 13) = ComboBox4.Value .Offset(, 15) = TextBox6.Value .Offset(, 16) = ComboBox5.Value .Offset(, 17) = TextBox3.Value .Offset(, 18) = TextBox4.Value .Offset(, 19) = TextBox5.Value End With For i = 1 To 6 Me.Controls("TextBox" & i) = "" Me.Controls("ComboBox" & i) = "" Next MsgBox Prompt:="تمت عملية ترحيل البيانات بنجاح", Title:="رسالة تأكيد" End Sub الملف مرفق fATHI.xlsm

الكود كما تريد Option Explicit Dim i%, Lr% Dim T As Worksheet Dim Spes_sh As Worksheet Dim Flter_rg As Range Dim RO% Sub ADD_Sheets() Set T = Sheets("تسجيل_الموظفين") Lr = T.Cells(Rows.Count, 2).End(3).Row If Lr < 8 Then Exit Sub With T For i = 8 To Lr If Not Application.Evaluate("ISREF('" & _ .Range("B" & i) & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = _ .Range("B" & i) End If Next End With End Sub '+++++++++++++++++++++++++++ Sub transfer_data() Application.ScreenUpdating = False ADD_Sheets T.Select Set Flter_rg = T.Range("A7").CurrentRegion For Each Spes_sh In Sheets If Spes_sh.Name <> T.Name Then Spes_sh.Range("A7").CurrentRegion.Clear Flter_rg.AutoFilter 2, Spes_sh.Name Flter_rg.SpecialCells(12).Copy With Spes_sh.Range("A7") .PasteSpecial (8) .PasteSpecial (12) .PasteSpecial (4) End With RO = Spes_sh.Cells(Rows.Count, 1).End(3).Row If RO > 7 Then Spes_sh.Range("A8").Resize(RO - 7).Value = _ Evaluate("Row(1:" & RO - 7 & ")") End If End If Next Spes_sh T.AutoFilterMode = False T.Select With Application .ScreenUpdating = True .CutCopyMode = False End With End Sub الملف لآحر مرة و سوف يغلق الموضوع بعد الرد مباشرة لأنه أخذ ما يزيد من الوقت Hatem_Last.xlsm

تم التعديل خطوات العمل كما في الصورة 1- تكتب في التكست بوكس الحرف(الحروف التي تريدها) 2-تحتار من الليست بوكس الصفوف التي تريدها (باستعمال الــ Ctrl أو Shift ) 3- تضغط على الزر Add To sheet 4- عندما يزيد عدد الصقوف (في الشيت) عن العدد 60 يتم التسجيل ابتداء من أول اللائحة (الملف مرفق) ismail_1.xlsm

تم معالجة الأمر بالنسبة (للبحث فقط) والباقي عليك لضيق الوقت ismail.xlsm

هل من الممكن أن يتم إنشاء شيتات تلقائية باسم البيانات الجديدة ممكن هذا الشيء Option Explicit Dim i%, Lr% Dim T As Worksheet Dim Spes_sh As Worksheet Dim Flter_rg As Range Sub ADD_Sheets() Set T = Sheets("تسجيل_الموظفين") Lr = T.Cells(Rows.Count, 2).End(3).Row If Lr < 8 Then Exit Sub With T For i = 8 To Lr If Not Application.Evaluate("ISREF('" & _ .Range("B" & i) & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = _ .Range("B" & i) End If Next End With End Sub '+++++++++++++++++++++++++++ Sub transfer_data() Application.ScreenUpdating = False ADD_Sheets T.Select Set Flter_rg = T.Range("A7").CurrentRegion For Each Spes_sh In Sheets If Spes_sh.Name <> T.Name Then Flter_rg.AutoFilter 2, Spes_sh.Name Flter_rg.SpecialCells(12).Copy Spes_sh.Range("A7").PasteSpecial (8) Spes_sh.Range("A7").PasteSpecial xlAll End If Next Spes_sh T.AutoFilterMode = False T.Select With Application .ScreenUpdating = True .CutCopyMode = False End With End Sub Hatem_new.xlsm

code Private Sub UserForm_Initialize() Me.Caption = "http://www.officena.net" Dim ws As Worksheet: Set ws = Sheets("المركز المالي") d = ws.Cells(Rows.Count, "D").End(xlUp).Row Me.ComboBox1.Clear For c = 5 To d If ws.Cells(c, "D").Interior.ColorIndex <> xlNone _ And ws.Cells(c, "D") <> vbNullString Then Me.ComboBox1.AddItem ws.Cells(c, "D") End If Next End Sub

1-تنسخ اولاً اي شيت غير الاولى 2- تعطيها اسم 2- ثم تدرج اسمها في الــ Array

1- اي شيت تقوم بزيادته اضف اسمه الى الــ Array Ash 2- للحصول على نقس التنسيق استبدل ما موجود في المربع الأحمر (بهذا السطر) Sheets(Itm).Range("A8").PasteSpecial (xlAll)

1-في شيت تسجيل_الموظفين اترك الصف رقم 6 فارغاً تماما تم اخفاه لعدم الكتابة فيه عن طريق الخطأ 2- في باقي الشيتات اترك الصف رقم 7 فارغاً تماما تم اخفاه لعدم الكتابة فيه عن طريق الخطأ 3- الكود المطلوب Option Explicit Sub My_filter() Dim Ash, Itm Dim Rg As Range Dim Main As Worksheet Dim Ro With Application .Calculation = xlCalculationManual .ScreenUpdating = False End With Ash = Array("التغذية", "تنسيق التعليم الإعدادي", _ "مكتب المدير العام", "شئون الطلبة والامتحانات") Set Main = Sheets("تسجيل_الموظفين") Ro = Main.Cells(Rows.Count, "B").End(3).Row Set Rg = Main.Range("A7").CurrentRegion Main.AutoFilterMode = False For Each Itm In Ash Sheets(Itm).Range("A8").CurrentRegion.Clear Rg.AutoFilter 2, Itm Main.Range("A8:Ar" & Ro).SpecialCells(12).Copy With Sheets(Itm).Range("A8") .PasteSpecial (8) .PasteSpecial (12) With .CurrentRegion .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 End With End With Next With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With Main.Select Main.AutoFilterMode = False End Sub الملف مرفق Hatem.xlsm

اذا كان لا بد من الكود Option Explicit Sub My_code() With Range("D2").Resize(, 2) Select Case True Case Range("C2") = vbNullString .Formula = "=SUMPRODUCT(($B$5:$B$50<=MAX($A$2:$B$2))*($B$5:$B$50>=MIN($A$2:$B$2))*D$5:D$50)" Case Else .Formula = "=SUMPRODUCT(($B$5:$B$50<=MAX($A$2:$B$2))*($B$5:$B$50>=MIN($A$2:$B$2))*($C$5:$C$50=$C$2)*D$5:D$50)" End Select .Value = .Value End With End Sub

المعادلة في الصورة تكتب و تسحب يساراً

في الخلية J2 هذه المعادلة (Ctrl+Shift+Enter) =SUM(IF(MOD(ROW(J$6:J$1000),2)=1,J$6:J$1000,0)) في الخلية J3 استدبل الرقم 1 بالرقم 0 (Ctrl+Shift+Enter) =SUM(IF(MOD(ROW(J$6:J$1000),2)=0,J$6:J$1000,0)) و الان ضع التنسيق الشرطي الذي تريده

ارفع ملف مع قليل من البيانات مع النتائج المتوقعة يدوياً ( وبدون زركشة ألوان تبهر البصر يمجرد التظر اليها وتجعل من يريد المساعدة يعزف عن ذلك

جمع تلقائي اكتب في أول صف فارغ من الخلية B الى الخلية E و عندما تكتمل البيانات في هذا الصف (4 عتاصر يقوم الماكرو بعمله) الصورة توضح ذلك (الملف مرفق) Summation_1.xlsm

1- لا تقم بالترقيم لأنة يدرج اوتوماتيكياُ في كل صف (عندما تمتلىء كل الخلايا) 2- اكتب ما تريد في الجدول بما فيه الخلية الخضراء 3- عند الانتهاء اضغط الزر Run Sub Auto_sum() Dim Rg As Range Dim Mmax% Dim ro% ro = Cells(Rows.Count, 1).End(3).Row Mmax = Application.Max(Range("A2:A" & ro)) + 3 Cells(Mmax - 1, 2).Resize(, 5).Interior.ColorIndex = xlNone With Cells(Mmax, "F") .Formula = "=SUM(F3:F" & Mmax - 1 & ")" .Value = "My_Sum : " & .Value .Interior.ColorIndex = 35 End With End Sub Summation.xlsm

جرب هذا الملف تضع في الخلية E1 اي رقم تريد وتطهر لك قائمة منسدلة من 1 حتى هذا الرقم في جال الجطأ الحلية E1 تساوي 1 Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address(0, 0) = "E1" _ And Target.Count = 1 _ And Val(Target) > 0 Then If Target < 1 Then Target = 1 Target = Int(Target) Me.Range("E1") = Target Tajriba End If Application.EnableEvents = True End Sub '++++++++++++++++++++ Sub Tajriba() Dim Mon_Array, s Dim y%: y = Range("E1") s = "Row(" & 1 & ":" & y & ")" Mon_Array = Application.Transpose(Evaluate(s)) With Range("A1").Validation .Delete .Add 3, Formula1:=Join(Mon_Array, ",") End With Range("A1") = 1 End Sub Var_dat_val.xlsm

الكود في حدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("B3")) Is Nothing _ And Target.Count = 1 And Target <> vbNullString Then Filter_me End If Application.EnableEvents = True End Sub الكود المطلوب للفلتره Option Explicit Sub Filter_me() Dim Rg As Range Dim Sh As Worksheet Dim Cret, cel As Range Dim Dic As Object Dim st1, st, i Set Dic = CreateObject("Scripting.dictionary") Set Sh = Sheets("Sheet1") Sh.Range("C3").Resize(, 6).ClearContents Sh.AutoFilterMode = False Set Rg = Sh.Range("A8").CurrentRegion If IsEmpty(Sh.Range("b3")) Then Exit Sub Cret = Sh.Range("b3") Rg.AutoFilter 1, Cret For Each cel In Rg.Columns(1).SpecialCells(12).Cells st1 = cel & "*" & cel.Offset(, 1) & "*" & cel.Offset(, 2) st = cel & "*" & cel.Offset(, 1) & "*" & cel.Offset(, 2) _ & "*" & cel.Offset(, 3) & "*" & cel.Offset(, 4) & "*" & cel.Offset(, 5) _ & "*" & cel.Offset(, 6) If Not Dic.Exists(st1) Then Dic(st1) = st End If Next With Sh.Range("C3") .Value = Split(Dic.Items()(Dic.Count - 1), "*")(1) .Offset(, 5) = Split(Dic.Items()(Dic.Count - 1), "*")(2) For i = 1 To 4 .Offset(, i) = Split(Dic.Items()(Dic.Count - 1), "*")(i + 2) Next End With Sh.AutoFilterMode = False Set Dic = Nothing End Sub الملف مرفق Salary Ch.xlsm