سليم حاصبيا

كيف تريد ان يعمل الكود ما دام لا يوجد تنسيق بين اسماء الشيات الفعلية واسماءها داخل الكود و حتى النطاق في الكود مختلف عما هو في الشيت الاساسي استبدل "Main" باسم الشبت الاساسي و "Final" باسم شيت الذي تريد نقل البيانات اليه واسم النطاق"A3:AN3" بنطاق العناوين في الشيت الاساسي

جرب هذا الملف والتعامل معه يتم حسب الصورة "User Form2" 1- في اليوزر "User Form2" الصفحة الأولى "Single sheet" مطابقة لليوزر الدي كنا نتعامل معه 2-في اليوزر الصفحة الثانية "All sheets" يقوم الكود بالبحث عن الكلمة التي تريدها من جميع الشيتات ما عدا "formula"و "Free" اللتين تركتهما احتياط في حال اردنا شيئاً جديداً 3 _يمكن ادراج صفحات اخرى قدر ما تريد (شرط التقيد بالجدول من الغامود A الى العامود H ( بدون خلايا فارغة في الجدول) و بنفس العناوين "كود الطالب" / "اسم الطالب ..... الخ.... الملف مرفق Doubl_User.xlsm

كان من المفورض طرح هذه الأسئلة مسبقاً و دون تضييع الوقت تم تعديل الماكرو خسب ما تريد Option Explicit Sub From_one_to_two() Dim M As Worksheet Dim F As Worksheet Dim LF%, col%, i% Dim F_rg As Range, y% Dim S_rg As Range Dim max_ro% Dim Flt_rg Application.ScreenUpdating = False Set M = Sheets("Main"): Set F = Sheets("Final") Set S_rg = M.Range("A3:AM3") col = F.Cells(3, Columns.Count).End(1).Column F.Range("a5").Resize(5000, col).Clear For i = 2 To col Set F_rg = S_rg.Find(F.Cells(3, i), lookat:=1) If F_rg Is Nothing Then GoTo Next_I y = F_rg.Column max_ro = M.Cells(Rows.Count, y).End(3).Row M.Cells(4, i).Resize(max_ro - 2).SpecialCells(12).Copy F.Cells(5, y).PasteSpecial (12) Next_I: Next LF = F.Range("A5").CurrentRegion.Rows.Count F.Range("A5").Resize(LF) = _ Evaluate("Row(" & 1 & ":" & LF & ")") F.Range("A5").Resize(LF).NumberFormat = "[$-,200] 0" With F.Range("A5").Resize(LF, col).SpecialCells(2) If .Cells(1, 1) <> vbNullString Then .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14: .Font.Bold = True End If End With F.PageSetup.PrintArea = F.Range("A3").Resize(LF + 2, col).Address Rem ++++++++++ Optional +++++++++++++++ ' If M.FilterMode Then ' M.Range("a3").CurrentRegion.AutoFilter ' End If Rem ++++++++++ Optional +++++++++++++++ Application.ScreenUpdating = True End Sub الملف من جديد Mhnd_7788_with filter.xlsm

جرب هذا الملف 1- تم تصحيح البيانات للقوائم المنسدلة 2 تم تغيير اسماء الصفخات الى اللغة الاجنبية 3- تم وضع بيانات عشوائية لزيادة الصفوف (صفين لا يكفيان) في الشيت الاساسي "’Main"' 4- في الصفحة "Final" استبدل اسم العامود الى ما تريد(من القائمة المنسدلة في الصف الثالث) 5- اضغط على الزر "Run Please" Option Explicit Sub From_one_to_two() Dim M As Worksheet Dim F As Worksheet Dim LF%, col%, i% Dim F_rg As Range, y% Dim S_rg As Range Dim max_ro% Application.ScreenUpdating = False Set M = Sheets("Main"): Set F = Sheets("Final") Set S_rg = M.Range("A3:AM3") col = F.Cells(3, Columns.Count).End(1).Column F.Range("a5").Resize(5000, col).Clear For i = 2 To col Set F_rg = S_rg.Find(F.Cells(3, i), lookat:=1) If F_rg Is Nothing Then GoTo Next_I y = F_rg.Column max_ro = M.Cells(Rows.Count, y).End(3).Row F.Cells(5, i).Resize(max_ro).Value = _ M.Cells(4, y).Resize(max_ro).Value Next_I: Next LF = F.Range("A5").CurrentRegion.Rows.Count F.Range("A5").Resize(LF) = _ Evaluate("Row(" & 1 & ":" & LF & ")") With F.Range("A5").Resize(LF, col).SpecialCells(2) If .Cells(1, 1) <> vbNullString Then .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14: .Font.Bold = True .Interior.ColorIndex = 19 End If End With Application.ScreenUpdating = True End Sub الملف مرفق Nhnd_7788.xlsm

تم التعديل كما تريد يمكنك الاختيار من القائمة المنسدلة أو كتابة الاسم يدوياً علماً ان القائمة المنسدلة لا تذكر المكرر الا مرة واحدة sader_mh_ali_New.xlsm

جرب هذه المعادلة =IF(ISNUMBER(B7),MAX($A$6:A6)+1,"") الملف مرفق My_file.xls

الكودات في اليوزر معقدة بعض الشيء لذلك قمت بنغييرها و وضعت لك االاكواد المناسبة اضغط على الزر Show User لاظهار اليوزرفورم تختار اسم الصف من الكومبو فتظهر لك في اليست بوكس كل البيانات لاضافة سجل >>>>>>>>>>>> تختار اسم الشيت من الكومبو وتملإ البيانات تم تضغط على "اضافة" اذا لم تكن الببيانات كافية(8 عناصر على عدد الأعمدة) يتم تلوين التكست بوكس الفارغ باللون الاحمر و يتوقف الكود عن العمل بانتظار تعبئة كل البيانات لحذف سجل >>>>>>>>>>>>>>>>>>> تحتار من الليست بوكس وتضغط حذف لتعديل سحل >>>>>>>>>>>1- تختار من الليست بوكس 2-تبدل ما تريد من خلال التكست بوكسات ثم تضغط على تعديل الملف يحتوي على صفحتين فقط ويمكن اضافة قدر ما تريد من الصفحات (بشرط التقيد بجدول البيانات من العامود A الى العامود H ) بدون صفوف فارغة abdo_1.xlsm

تم التعديل Shafii_1.xlsx

في حال تكرر الاسم اكثر من مرة كيف يمكن للتكست بوكس (الاسماء) ان يتسع اكثر من اسم واحد و للتكست بوكس (الرقم) ان يتسع اكثر من رقم واحد الخ..... اذا اردت يمكن عمل ذلك على الصفحة وليس داخل اليوزر كما في هذا الملف (صفحة 2) sader_mh_ali_2.xlsm

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

جربي هذا الكود Option Explicit Sub Salim_Code_Only_Positive() Rem <<<< Created By Salim Hasbaya On 27/7/2020 >>>> Dim a() Dim Sh As Worksheet, D As Worksheet Dim m%, k%, x%, t% Dim Rg As Range, XX%, cnt% Dim dat1 As Date, dat2 As Date Dim Itm, cel As Range Application.ScreenUpdating = False k = 1 Set D = ThisWorkbook.Worksheets("DataReport") D.Range("A2:k" & Rows.Count).Clear If Not IsDate(D.Range("M2")) Or _ Not IsDate(D.Range("M2")) Then MsgBox "Wrong dates in cells M1 Or N2" GoTo Leave_me_Olone End If dat1 = Application.Min(D.Range("M2:N2")) dat2 = Application.Max(D.Range("M2:N2")) For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> D.Name And Sh.Tab.Color = 5287936 Then ReDim Preserve a(1 To k): a(k) = Sh.Name: k = k + 1 End If Next m = 2: k = 2 For Each Itm In a Set Sh = Sheets(Itm) x = Sh.Cells(Rows.Count, 1).End(3).Row Sh.Cells(6, 1).Resize(x - 5, 10).Interior.ColorIndex = xlNone For t = 6 To x If Sh.Cells(t, 1) >= dat1 And Sh.Cells(t, 1) <= dat2 Then For XX = 3 To 10 If Sh.Cells(t, XX) < 0 Then cnt = cnt + 1 Exit For End If Next XX If cnt = 0 Then If Rg Is Nothing Then Set Rg = Sh.Cells(t, 1).Resize(, 10) Else Set Rg = Union(Rg, Sh.Cells(t, 1).Resize(, 10)) End If End If End If cnt = 0 Next t If Not Rg Is Nothing Then D.Cells(m, 1) = Rg.Parent.Name Rg.Copy D.Cells(m, 2) Rg.Interior.ColorIndex = 27 m = D.Cells(Rows.Count, 2).End(3).Row + 3 D.Cells(m - 2, 1) = "Totat" D.Cells(m - 2, 4).Resize(, 8).Formula = _ "=SUM(D" & k & ":D" & m - 3 & ")" D.Cells(m - 1, 3).Resize(, 10).Value = _ D.Cells(1, "C").Resize(, 10).Value D.Cells(m - 2, 1).Resize(, 11).Interior.ColorIndex = 35 D.Cells(m - 1, 1).Resize(, 11).Interior.ColorIndex = 40 k = m End If Set Rg = Nothing Next Itm D.Cells(m, 1) = "Sum off All" D.Cells(m, 4).Resize(, 8).Formula = _ "=SUM(D2:D" & m - 1 & ")/2" D.Cells(m, 1).Resize(, 11).Interior.ColorIndex = 39 D.Cells(m - 1, 1).EntireRow.Delete Set Rg = D.Range("A2").CurrentRegion If Rg.Rows.Count > 1 Then Set Rg = Rg.Offset(1).Resize(Rg.Rows.Count - 1) With Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True .Font.Size = 14 .Value = .Value End With End If Leave_me_Olone: Set Sh = Nothing: Set D = Nothing Set Rg = Nothing: Erase a Application.ScreenUpdating = True End Sub الملف مرفق yara_salim_Only_positive_special.xlsm

الآن اصبح الموضوع اكثر تعقيداً كان من المفروض طرح هذا الموضوع مرة واحدة لاني اشتغلت على ما طلبته حسب سؤالك "حيث لا يستدعى الارقام السالبة"

بعد اذن اخي الرائد حل اخر Hathromi.xlsx

تم معالجة الأمر yara_salim_Only_positive.xlsm

تم عمل المطلوب مع بعض التغبرات في تصميم اليوزر (لاظهار اليوزر اضغط الزر "Show_User") 1- للبحث في خانة "اليحث عن الرقم" * اكتب ما تريد البحث عنه بعد التأكد من وجوده في العامود الخامس "E" * اضغط "ُ Enter" او اي شيء أو اي مفتاح (غير الحروف والأرقام) المفتاح Tab مثلاً او انقر في TextBox اخر على اليورز * تظهر لك محتويات السطر المطلوب البحث عنه من خلال الرقم ___________________________________________________________________ 2- للبحث في خانة "اليحث عن الاسم" * اكتب ما تريد البحث عنه بعد التأكد من وجوده في العامود الرابع "D" * اضغط "ُ Enter" او اي شيء أو اي مفتاح (غير الحروف والأرقام) المفتاح Tab مثلاً او انقر في TextBox اخر على اليورز * تظهر لك محتويات السطر المطلوب البحث عنه من خلال الاسم --------------------------------------------------------------------------------------------- 3- للتعديل * اكتب ما تريد البحث عنه في التكست بوكس (جانب الزر تعديل) * اضغط "ُ Enter" او اي شيء أو اي مفتاح * في بيانات اليورز غير ما تريد ( 4 كومبوبوكسات) * اضغط الزر تعديل (اذا كان التاريخ حطأ تظهر لك رسالة بذلك و يتوقف الماكو) --------------------------------------------------------------------------------------------- 4-نفس الشي بالنسبة للحذف --------------------------------------------------------------------------------------------- 5 _لاضاقة بيانات املا التكست بوكسات (4) واضغط اضافة (يجب ان تكون جميع التكست بوكسات غير فارغة والتاريع مكتوب بشكل يوم /شهر /سنة) sader_mh_ali_1.xlsm

وضغت لك كودين للبحث (الاسم والرقم) يمكنك ايضاً التنقل من خلية الى اخرى داخل الصفحة او حتى الانتقال الى صفحة اخرى حتى ولو كان اليوزرفورم ظاهراً اكتب الاسم او الرقم الصادر واضغط Enter في حال عدم وجود ما تبحث عنه تظهر لك رسالة بذلك يمكنك اكمال باقي الاكواد كما في الملف (لا استطيع عمل ذلك لضيق الوقت) sader_mh_ali.xlsm

الظاهر انك لم تنتبه الى الملاحطة الأولى في الرد الذي رفعته لك 1- عملية اخفاء الاعمدة لا تتم الا اذا كانت الخلايا من B الى H غير فارغة (7 عتاصر) لذلك اكتب ما تشاء في اي صف من الخلية الىB الخلية H و عندما تنتقل الى الخلية i وتكتب العدد المطلوب (بين 1 و 24) يتم تنفيذ الأمر

حرب هذا الملف 1- عملية اخفاء الاعمدة لا تتم الا اذا كانت الخلايا من B الى H غير فارغة (7 عتاصر) 2-بعد تعبئة البيانات من B الى H مجرد ان تدخل عدد الاقساط المطلوبة في الخلية I يتم اظهار عدد الاعمدة المطلوبة 3-زرين اضاقيين لاخفاء الاغمدة من M الى AJ واظهارها اذا كان هناك حاجة لذلك Show_hid_col.xlsm

ماكرو اخر يقوم بنفس المهمة Option Explicit Sub FIND_EMPLOY() Dim mPath$ Dim F_Name, TS$ Application.ScreenUpdating = False If UCase(ActiveSheet.Name) <> "SALIM" Then GoTo BAY_BAY_YA_HILWEEN mPath = ThisWorkbook.Path & "\" F_Name = mPath & "[Empl.xlsx]" F_Name = F_Name & "DATA'!$A$2:$J$100" Range("B3").Resize(, 9).ClearContents TS = "VLOOKUP($A3,'" & F_Name & ",COLUMNS($A$1:B1)" & ",0" & ")" TS = "=IFERROR(" & TS & ","""")" With Range("B3").Resize(, 9) .Formula = TS .Value = .Value End With If Range("B3") = vbNullString Then MsgBox "THIS CODE :" & Chr(10) & _ """" & Range("A3") & """" & Chr(10) & _ "DOES'T EXITS IN WORKBOOK "" Empl.Column(A)"" " Range("A3").ClearContents End If BAY_BAY_YA_HILWEEN: Application.ScreenUpdating = True End Sub

جرب هذا المصنف 1-مؤلف من ملفين الاول تجت اسم "Empl.xlsx" و الثاني تحت اسم "Rateb.xlsm" 2-البحث يتم في الملف "Rateb.xlsm" 3- اختر كود الموظف من الخلية A3 واضغط الزر "هاتها دكتور اكسل" Empl.xlsx Rateb.xlsm

و ما الحاجة الى ملفين لهذه الغاية يكفي في الملف الاساسي وضع صفحة مخصصة للحصول على البيانات مثل هذا (الصفحة Salim) Employ_data.xlsx

بعد اذن اخي الرائد تم ادراج صفين الى البيانات لتفادي الخلايا المدمجة( الصف رقم 2 والصف رقم 4 (الصفوف مخفية) Nabatshi.xlsx

جرب هذا الملف Max_Min.xls

حطأ بسيط بالكود يحب استبدال حرف الــ J بالحرف M كما في الصوررة mostafa _new 2.xlsm

جرب هذا الشيئ كمثال (تحديد ما تريده فقط من الحلية ) في المثال الرقم 2