سليم حاصبيا

انت تدرج الوقت بشكل خاطىء في الخلايا (حيث اكسل لا يمكنه التعرف عليه) لذلك قمت بعمل هذا النموذج فيه شرح لكيفية ادراج الوقت والمعادلات اللازمة مع حرية اختيار وقت العمل (من الى) وتغيير المكافأة الى الرقم الذي تريد ليس فقط 15 دقيقة المعادلات محمية لعدم العبث بها عن طريق الخطأ /عسى ان ينال الاعجاب Time_calculation.xlsx

لك ما تريد Hidden_rows .xlsm

تم معالجة الامر لا تختفي الصفوف الا اذا كان الصف من ( A ِ الى D ) مكتملاً ( 4 عناصر) Code Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("a2:d99")) Is Nothing _ And Application.CountA(Range(Cells(Target.Row, 1), Cells(Target.Row, 4))) = 4 Then hid_My_row (Target.Row) End If End Sub Rem++++++++++++++++++++++++++++++++++ Sub hid_My_row(k%) Rows(k + 2 & ":" & 104).Hidden = True Rows(1 & ":" & k + 1).Hidden = False Cells(k + 1, 1).Select End Sub Rem++++++++++++++++++++++++++++++++++ Sub SHOW_ME() Rows(1 & ":" & 105).Hidden = False End Sub Rem++++++++++++++++++++++++++++++++++ hide_Any_wher_ROWS.xlsm

تابع هذه الصورة

حاول استبدال الفاصلة المنقوطة بفاصلة عادية لتبدو المعادلة هكذا =if(B1<>"",counta($B$1:B1),"")

تفضل Print_vis_ROWS.xlsm

جرب هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim x If Target.Column = 1 And _ Target.Count = 1 And Target.Row < 100 Then x = Range("A:a").Find("", after:=Cells(1, 1)).Row hid_My_row (x) End If End Sub Rem++++++++++++++++++++++++++++++++++ Sub hid_My_row(k%) Rows(k + 1 & ":" & 100).Hidden = True Rows(1 & ":" & k).Hidden = False Cells(k - 1, 1).Offset(, 1).Select End Sub Rem++++++++++++++++++++++++++++++++++ Sub SHOW_ME() Rows(1 & ":" & 100).Hidden = False End Sub Rem++++++++++++++++++++++++++++++++++ الملف للتجربة مرفق SHOW_HIDE_ROWS.xlsm

لا استطيع فهم ما تريد ارفع نموذج بسيط ( أقل من 10 صفوف لا 250 صف) مع النتائج التي تتوقعها (اكتبها يدوياً) و ماذا تريد ان تفعل بالاسماء المكررة

في الملف المرفق منك يا استاذ حاتم بعض الاخطاء (يجب تصحيحها كي يعمل الكود بكفاءة) 1- الرقم القومي في البداية موجود وفي العامود الاول ورقم الجلوس في الثاني اما في الشيتات بعد 2Home تنعكس الاية (تم تصحيح الامر بالنسبة لهذه النقطة) 2 _اختلاف في محتوبات الاعمدة بين الصفحات قبل 2Home وبعدها (مثال اللغة العربية في Column H ثم في Column G) في الملف المرفق مني تم حذف 2Home والاستعانة بورقة Fasel (فارغة) تفصل بين الاعدادي والابتدائي والتي يأخذها الاكسل كمرجع لبداية البحث) (تم ادراج عاموين فارغين قبل اللغة العربية في الاعداديات ليصبح كل شيء في موقعه الصحيح) كيفية العمل بالكود 1- الصفحة Fasel يمكن اخفاؤها لانها فقط فاصل بين المرحلتين(اختيارياُ) 4- المرحلة الابتدائية يبدأ لبحث من الصفحة 2 حتى ما قبل الصفحة Fasel 5- المرحلة الاعدادية يبدأ البحث من الصفحة ما بعد Fasel الى نهاية عدد الصفحات 6 - تختار ابتدائي او اعدادي من القائمة المنسدلة في الخلية P2 صفحة Home ثم تكتب الرقم القومي وتضغط الزر الآن لوّن و زخرف كما تشاء الكود Option Explicit Sub find_Studant_Data() Dim sh_ind% sh_ind = Sheets("fasel").Index Dim start_page%, end_page% On Error Resume Next Dim My_St: My_St = Sheets("Home").Cells(2, "L") Dim sh As Worksheet Dim r%, n%, SH_name$ Dim find_rg As Range Dim Adr$, col%: col = 2 Dim k% Dim arr_Even(1 To 13) Dim arr_Odd(1 To 12) Range("My_range") = vbNullString '========================================== arr_Even(1) = 6: arr_Even(2) = 8: arr_Even(3) = 10: arr_Even(4) = 12 arr_Even(5) = 14: arr_Even(6) = 16: arr_Even(7) = 20: arr_Even(8) = 22 arr_Even(9) = 18: arr_Even(10) = 24: arr_Even(11) = 26: arr_Even(12) = 28 arr_Even(13) = 30 For n = 1 To UBound(arr_Even) - 1 arr_Odd(n) = arr_Even(n) + 1 Next '============================= Select Case Sheets("Home").Cells(2, "P") Case "الابتدائى": start_page = 2: end_page = sh_ind - 1 Case Else: start_page = sh_ind + 1: end_page = Sheets.Count End Select For n = start_page To end_page Set find_rg = Sheets(n).Range("B:B").Find(My_St, Lookat:=xlWhole) If Not find_rg Is Nothing Then r = find_rg.Row Adr = find_rg.Address Set sh = Sheets(n) With Sheets("Home") .Cells(2, "F") = Sheets(n).Name & ":" & Adr 'KK .Cells(4, "B") = sh.Range(Adr).Offset(, 2) 'ok .Cells(4, "K") = sh.Range(Adr).Offset(, -1) 'ok .Cells(5, "B") = sh.Range(Adr).Offset(, 1) 'ok .Cells(5, "K") = sh.Range(Adr) .Cells(3, "A") = Sheets(n).Cells(1, "G") & " " & .Cells(6, "c") '===================================== For k = LBound(arr_Even) To UBound(arr_Even) .Cells(12, col) = sh.Range(Adr).Offset(, arr_Even(k)) col = col + 1 Next col = 2 For k = LBound(arr_Odd) To UBound(arr_Odd) .Cells(13, col) = sh.Range(Adr).Offset(, arr_Odd(k)) col = col + 1 Next '============================= End With Exit For End If Next If r = 0 Then MsgBox "Not Found" & Chr(10) & _ "The Number: " & My_St & " Does't Exists", 64, "Salim Tell You" Erase arr_Even: Erase arr_Odd End Sub الملف Super_notes.xlsm

الخلايا المدمجة عدو الاكواد الأول ///لا يمكن ان تنسخ رقم (الرقم القومي مثلا أو الاسم) من خلية عادية الى مجموعة حلايا مدمجة بدون مشاكل)/// لذلك كي أستطيع المساعدة عليك انشاء ملف جديد (مختصر بالبيانات قدر الامكان) مثلاً 4 صفحات(A,B,C,D) في كل منها 10 صفوف لا أكثر بدون خلايا مدمجة و بدون زوزقة ألوان تبهر النظر) تستطيع تنسيق الخلايا وتلوينها كما تريد بعد التأكد من عمل الأكواد فعندما تعمل على ملف صغير تستطيع ان ترى ما يفعله الكود و بعدها تعمم الكود على الملفات الكبيرة لا أعرف لماذا استعمال (الخلايا المدمجة) طالما يستطيع المستخدم اختيار عرض العامو د و ارتفاع الصف حسب حاجته

تم معالجة الامر كانت هناك ورقة بيضاء بالملف تسببت بالخطأ تم التعدبل على الكود ليغض النظر عن هذا الشيء Option Explicit Sub Salim_New_filter() With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With With Sheets("SALIM_BALANCE") .Range("A2:J" & Rows.Count).Clear .Range("k:k").Clear End With Dim x% Dim i%, D%: D = 1 Dim y%, k%: k = 1 Dim xx%, m% Dim t1%, t2% Dim Saerch_Rg As Range For m = 1 To Worksheets.Count With Sheets(m) If .Name <> "SALIM_BALANCE" Then x = Application.Max(.Range("a:a")) + 1 Set Saerch_Rg = .Range("B:B").Find("*", after:=Cells(x, 2), LookIn:=xlFormulas) If Not Saerch_Rg Is Nothing Then y = Saerch_Rg.Row Else: y = 0 GoTo Next_m End If Sheets("SALIM_BALANCE").Range("B" & D + 1).Resize(x - 1, 9).Value = _ .Range("b2").Resize(x, 9).Value t1 = D + 1 With Sheets("SALIM_BALANCE") With .Cells(D + 1, "K") .Value = "BEGIN OF SHEET: " & Sheets(m).Name .Interior.ColorIndex = 20 D = D + x - 1 t2 = D End With .Cells(t2, "K") = "END OF SHEET: " & Sheets(m).Name .Cells(t2, "K").Interior.ColorIndex = 44 .Cells(t2 + 1, "H").Formula = "=SUM(H" & t1 & ":H" & t2 & ")" .Cells(t2 + 1, "J").Formula = "=SUM(J" & t1 & ":J" & t2 & ")" .Cells(t2 + 1, 1).Resize(, 11).Interior.ColorIndex = 35 .Cells(t2 + 1, "K") = "SUMMATION Of SHEET " & Sheets(m).Name D = D + 1 End With End If End With Next_m: Next With Sheets("SALIM_BALANCE") xx = .Cells(Rows.Count, "b").End(3).Row For i = 2 To xx If .Range("A" & i).Interior.ColorIndex <> 35 Then .Range("A" & i) = k k = k + 1 Else k = 1 End If Next With .Range("A2:K" & xx + 1) .Borders.LineStyle = xlContinuous .Font.Bold = True .InsertIndent 1 End With .Range("B2:B" & xx).NumberFormat = "d/m/yyyy" End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With Sheets("SALIM_BALANCE").Select End Sub Mars_Account_new.xlsm

جرب هذا النموذج (ربما كان الافضل) Working time_salim.xlsx

شاهد هذا الفيديو التعليمي بهذا الشأن https://www.youtube.com/watch?v=eLWRqGGdGEQ

في أول كود تمت عملية البحث باستخدام الاسم يمكنك ادراج زر مخصص لهذا الكود بقي الرقم القومي تفعله مشابهاً للماكرو عملية البحث باستخدام الاسم مع ادراج المصفوفات Arr_ODD & ARR-Even بما يتناسب مع وضع العامود الذي نبحث فيه ربما يقوم الاستاذ علي بهذه المهمة اذا كان وقته يسمح بذلك لاني حقيقة ليس لدي الوقت الكافي لهذا الامر

الان يمكن العمل العمل بكل بساطة Option Explicit Sub find_Studant_Data() On Error Resume Next Dim My_St: My_St = Sheets("Home").Cells(2, "L") Dim sh As Worksheet Dim r%, n%, SH_name$ Dim find_rg As Range Dim Adr$, col%: col = 2 Dim k% Dim arr_Even(1 To 13) Dim arr_Odd(1 To 12) Range("My_range") = vbNullString '========================================== arr_Even(1) = 6: arr_Even(2) = 8: arr_Even(3) = 10: arr_Even(4) = 12 arr_Even(5) = 14: arr_Even(6) = 16: arr_Even(7) = 20: arr_Even(8) = 22 arr_Even(9) = 18: arr_Even(10) = 24: arr_Even(11) = 26: arr_Even(12) = 28 arr_Even(13) = 30 For n = 1 To UBound(arr_Even) - 1 arr_Odd(n) = arr_Even(n) + 1 Next '============================= For n = 2 To Sheets.Count Set find_rg = Sheets(n).Range("B:B").Find(My_St, Lookat:=xlWhole) If Not find_rg Is Nothing Then r = find_rg.Row Adr = find_rg.Address Set sh = Sheets(n) With Sheets("Home") .Cells(2, "F") = Sheets(n).Name & ":" & Adr .Cells(4, "C") = sh.Range(Adr).Offset(, 2) .Cells(6, "C") = sh.Range(Adr).Offset(, 1) .Cells(4, "K") = sh.Range(Adr).Offset(, -1) .Cells(6, "K") = sh.Range(Adr) .Cells(2, "J") = sh.Range(Adr).Offset(, -1) .Cells(2, "K") = sh.Range(Adr).Offset(, 2) '===================================== For k = LBound(arr_Even) To UBound(arr_Even) .Cells(14, col) = sh.Range(Adr).Offset(, arr_Even(k)) col = col + 1 Next col = 2 For k = LBound(arr_Odd) To UBound(arr_Odd) .Cells(15, col) = sh.Range(Adr).Offset(, arr_Odd(k)) col = col + 1 Next '============================= End With Exit For End If Next If r = 0 Then MsgBox "Not Found" & Chr(10) & _ "The Number: " & My_St & " Does't Exists", 64, "Salim Tell You" Erase arr_Even: Erase arr_Odd End Sub الملف مرفق اFind_notes New_Edition.xlsm

لا يمكن البحث برقم الجلوس لانه يتكرر في كل صفحة مثلاً نبحث عن الرقم الجلوس 1650 اكسل يجد محمد في الشيت 2010 و يجد خليل في الشيت 2013 ويجد أحمد في الشيت 2015 عندها تحصل على أكثر من نتيجة لاكثر من طالب فكيف تدرج اكثر من نتيجة في كل خلية من جدول

حرب هذا الكود للبحث فن الاسم (يمكنك عمل مثله للبحث عن الرقم القومي) Option Explicit Sub find_St() Dim My_St$: My_St = Sheets("Home").Cells(2, "J") Dim sh As Worksheet Dim r%, n%, SH_name$ Dim find_rg As Range Dim Adr$, col%: col = 2 Dim k% Dim arr_even(1 To 13) Dim arr_Odd(1 To 12) Range("My_range") = vbNullString '========================================== arr_even(1) = 4: arr_even(2) = 6: arr_even(3) = 8: arr_even(4) = 10 arr_even(5) = 12: arr_even(6) = 14: arr_even(7) = 18: arr_even(8) = 20 arr_even(9) = 16: arr_even(10) = 22: arr_even(11) = 24: arr_even(12) = 26 arr_even(13) = 28 For n = 1 To UBound(arr_even) - 1 arr_Odd(n) = arr_even(n) + 1 Next '============================= For n = 2 To Sheets.Count Set find_rg = Sheets(n).Range("D:D").Find(My_St) If Not find_rg Is Nothing Then r = find_rg.Row Adr = find_rg.Address Set sh = Sheets(n) With Sheets("Home") .Cells(2, "F") = Sheets(n).Name & ":" & Adr .Cells(4, "C") = sh.Range(Adr) .Cells(6, "C") = sh.Range(Adr).Offset(, -1) .Cells(4, "K") = sh.Range(Adr).Offset(, -3) .Cells(6, "K") = sh.Range(Adr).Offset(, -2) '===================================== For k = LBound(arr_even) To UBound(arr_even) .Cells(14, col) = sh.Range(Adr).Offset(, arr_even(k)) col = col + 1 Next col = 2 For k = LBound(arr_Odd) To UBound(arr_Odd) .Cells(15, col) = sh.Range(Adr).Offset(, arr_Odd(k)) col = col + 1 Next '============================= End With Exit For End If Next If r = 0 Then MsgBox "Not Found": Exit Sub Erase arr_even: Erase arr_Odd End Sub الملف مرفق اFind_notes.xlsm

تأكد من ذلك من خلال هذا الملف انا قمت بأخذ اخر تاريخ في الصف بغض النظر عن قيمته (حسب ما فهمت من سؤالك) اذا كنت تريد التاريخ الاقرب الى اليوم يلزم معادلة اخرى Laste_date _new.xlsx

لا يمكن البحث برقم الجلوس لانه يتكرر في كل صفحة

هذه المعادلة ربما تنفع =IFERROR(LOOKUP(MAX(D8:H8)+1,D8:H8),"لايوجد") الملف مرفق Laste_date.xlsx

تم التعديل اكثر وأكثر ليبدو الامر أكثر وضوحاً Option Explicit Sub Salim_filter1() With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With With Sheets("SALIM_BALANCE") .Range("A2:J" & Rows.Count).Clear .Range("k:k").Clear End With Dim x% Dim i As Byte, D%: D = 1 Dim y%, k%: k = 1 Dim xx%, m% Dim t1%, t2% For m = 1 To Worksheets.Count With Sheets(m) If .Name <> "SALIM_BALANCE" Then x = Application.Max(.Range("a:a")) + 1 y = .Range("B:B").Find("*", after:=Cells(x, 2), LookIn:=xlFormulas).Row Sheets("SALIM_BALANCE").Range("B" & D + 1).Resize(x - 1, 9).Value = _ .Range("b2").Resize(x, 9).Value t1 = D + 1 With Sheets("SALIM_BALANCE") With .Cells(D + 1, "K") .Value = "BEGIN OF SHEET: " & Sheets(m).Name .Interior.ColorIndex = 20 D = D + x - 1 t2 = D End With .Cells(t2, "K") = "END OF SHEET: " & Sheets(m).Name .Cells(t2, "K").Interior.ColorIndex = 44 .Cells(t2 + 1, "H").Formula = "=SUM(H" & t1 & ":H" & t2 & ")" .Cells(t2 + 1, "J").Formula = "=SUM(J" & t1 & ":J" & t2 & ")" .Cells(t2 + 1, 1).Resize(, 11).Interior.ColorIndex = 35 .Cells(t2 + 1, "K") = "SUMMATION Of SHEET " & Sheets(m).Name D = D + 1 End With End If End With Next With Sheets("SALIM_BALANCE") xx = .Cells(Rows.Count, "b").End(3).Row For i = 2 To xx If .Range("A" & i).Interior.ColorIndex <> 35 Then .Range("A" & i) = k k = k + 1 Else k = 1 End If Next With .Range("A2:K" & xx + 1) .Borders.LineStyle = xlContinuous .Font.Bold = True .InsertIndent 1 End With .Range("B2:B" & xx).NumberFormat = "d/m/yyyy" End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With Sheets("SALIM_BALANCE").Select End Sub الملف الجديد tartib _mars new_1.xlsm

تم معالجة الامر بالنسية للمعادلات في (سعر الطن)تم تصحيحها اختصرت البملف الى 3 صفحات مع عدد اقل من البيانات لمراقبة عمل الكود يمكن نقل الكود الى الملف الصحيح و تصحيح المعادلات هناك Option Explicit Sub Salim_filter1() 'On Error Resume Next With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With With Sheets("SALIM_BALANCE") .Range("A2:J" & Rows.Count).Clear .Range("k:k").Clear End With Dim x As Integer, LAST_ROW Dim i As Byte, D%: D = 1 Dim y%, k%: k = 1 Dim xx% For i = 1 To Worksheets.Count With Sheets(i) If .Name <> "SALIM_BALANCE" Then x = Application.Max(.Range("a:a")) + 1 '========================== y = .Range("B:B").Find("*", after:=Cells(x, 2), LookIn:=xlFormulas).Row '================ .Range("b2:J" & x).Copy Sheets("SALIM_BALANCE").Range("B" & D + 1) With Sheets("SALIM_BALANCE") With .Cells(D + 1, "K") .Value = "BEGIN OF SHEET: " & Sheets(i).Name .Interior.ColorIndex = 20 D = D + x - 1 End With .Cells(D, "K") = "END OF SHEET: " & Sheets(i).Name .Cells(D, "K").Interior.ColorIndex = 44 With .Cells(D + 1, 1).Resize(, 10) .Value = Sheets(i).Cells(y, 1).Resize(, 10).Value .NumberFormat = "General" .Interior.ColorIndex = 35 End With .Cells(D + 1, "K") = "SUM" D = D + 1 End With End If End With Next With Sheets("SALIM_BALANCE") xx = .Cells(Rows.Count, "b").End(3).Row For i = 2 To xx If .Range("A" & i).Interior.ColorIndex <> 35 Then .Range("A" & i) = k k = k + 1 Else k = 1 End If Next End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With Sheets("SALIM_BALANCE").Select End Sub الملف tartib _mars new.xlsm

جرب هذا الماكرو Sub Salim_filter() 'On Error Resume Next With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With With Sheets("SALIM_BALANCE") .Range("B2:H" & Rows.Count).ClearContents .Range("k:k").Clear End With Dim x As Integer, LAST_ROW Dim i As Byte, D%: D = 1 For i = 1 To Worksheets.Count With Sheets(i) If .Name <> "SALIM_BALANCE" Then x = .Range("A" & Rows.Count).End(xlUp).Row .Range("b2:H" & x).Copy Sheets("SALIM_BALANCE").Range("B" & D + 1) With Sheets("SALIM_BALANCE") .Cells(D + 1, "K") = "BEGIN OF SHEET: " & .Name .Cells(D + 1, "K").Interior.ColorIndex = 35 D = D + x + 1 .Cells(D - 2, "K") = "END OF SHEET: " & .Name .Cells(D - 2, "K").Interior.ColorIndex = 44 End With End If End With Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With Sheets("SALIM_BALANCE").Select End Sub الملف مرفق tartib _mars.xlsm

وهل 72 في اعتقادك رقم عشري

جرب هذا الكود Option Explicit Sub copy_data() Dim my_rg As Range Dim col#, x# Set my_rg = Sheets("sheet1").Range("b2", Range("b3").End(4)) col = Sheet2.Rows(2).Find(vbNullString, after:=Cells(2, Columns.Count) _ , SearchDirection:=1).Column If col > 1 Then x = Application.CountIf(Sheet2.Rows(2), "<>" & "") * 2 - 1 col = Sheet2.Rows(2).Find(vbNullString, after:=Cells(2, x), _ SearchDirection:=1).Column + 1 End If Sheet2.Cells(2, col).Resize(my_rg.Rows.Count, 1).Value = my_rg.Value End Sub الملف مرفق salim_test.xlsm