محي الدين ابو البشر

أخي الكريم عملت على الملف الأول ولم انتبه إلى تعديل الملف 
على كل جرب هذا عسى يكون المطلوب
Double Dlick على إي خلية في العمود E (رقم ملف الحالة) سوف يظهر التقرير الخاص ...
Book2.xls

هذا آخر ملف لك مع الكود المنقح ويعمل جيداً 
بعد الأخذ بعين الاعتبار الملاحظة التالية إذا سمحت لي:
حسب العمود الأول لديك 
دائما تبدأ بـ اسم المدرسة ثم "المدرسة" ، أرقام الكتتاب ثم "رقم الاكتتاب" ..... وفي النهاية الديانات  ثم "الديانة" هذا الكلام جميل ولا غيار عليه
ولكن لا أدري لماذا  في بعض المدارس يختلف الترتيب  في الديانات "الديانة" ثم الديانات 
جرب الملف المرفق مع التعديل عسى يناسبك
 
 
تحويل عمود 4 معدل.xlsm

وعليكم السلام وارحمة
استبدل 1 بـ 2
 
B1.xlsm

السلام عليكم 
حسب ما فهمت من الملف المرفق من قيبل السيد sabah2023
هناك سوء فهم بتعبير الصفحة
لذلك اقترح الكود التالي
Sub test() Dim i& For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row Step 27 Rows(i & ":" & i + 1).RowHeight = 30 Rows(i + 2 & ":" & i + 26).RowHeight = 20 Next End Sub  

وعليكم السلام والرحمة
ربما
Sub test() Dim a, w, x, k Dim i&, ii& a = Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 5 To UBound(a) If Not .exists(a(i, 9)) Then .Add a(i, 9), Array(a(i, 9), a(i, 2), a(i, 3) & "\" & a(i, 4), "SP" & a(i, 5) & " PORT " & Format(a(i, 6), "0#"), "TB Number " & Format(a(i, 7), "0#")) Else w = .Item(a(i, 9)) x = Split(w(3), "-") If UBound(x) > 0 Then w(3) = x(0) & "- " & Format(a(i, 6), "0#") .Item(a(i, 9)) = w Else x(UBound(x)) = x(UBound(x)) & " -" & Format(a(i, 6), "0#") w(3) = Join(x) .Item(a(i, 9)) = w End If: End If Next For Each k In .keys Cells(5 + ii, 13).Resize(5) = Application.Transpose(.Item(k)) ii = ii + 6 Next End With End Sub  

هكذا؟
Sub Triage() With ActiveWorkbook.Worksheets("BLF").ListObjects("Tableau2") .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("Tableau2[Date Echeance]") .Sort.SortFields.Add2 Key:=Range("Tableau2[Client]") With .Sort .Header = xlYes .Apply End With End With End Sub  

If x > 45 And cells(I,"H")= "" Then  

وعليكم السلام
من
Format cells - Custom 
اكتب في حقل Type:
yyyymmdd
 

عليكم السلام
عسى
غياب يومية.xlsm

هكذا؟
Sub test() Dim dic1 As Object: Dim dic2 As Object Dim a, b, w, bb Dim i& a = Sheets("فودا").Cells(1).CurrentRegion b = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(2)) bb = Application.Transpose(Sheets("قاعدة العملاء").Cells(1).CurrentRegion.Columns(1)) Set dic1 = CreateObject("scripting.dictionary") Set dic2 = CreateObject("scripting.dictionary") For i = 2 To UBound(a) If (IsNumeric(Application.Match(a(i, 3), b, 0))) Then If Not dic1.exists(a(i, 3)) Then dic1.Add a(i, 3), Array(a(i, 3), bb(Application.Match(a(i, 3), b, 0)), a(i, 7)) Else w = dic1.Item(a(i, 3)) w(2) = w(2) + a(i, 7) dic1.Item(a(i, 3)) = w End If Else If Not dic2.exists(a(i, 3)) Then dic2.Add a(i, 3), Array(a(i, 3), a(i, 2), a(i, 7)) Else w = dic2.Item(a(i, 3)) w(2) = w(2) + a(i, 7) dic2.Item(a(i, 3)) = w End If End If Next With Sheets("رحل") Union(Range(.Cells(3, 1), .Cells(3, 5).End(xlDown)), Range(.Cells(3, 8), .Cells(3, 11).End(xlDown))).ClearContents .Cells(3, 1).Resize(dic1.Count, 3) = Application.Index(dic1.items, 0, 0) .Cells(3, 8).Resize(dic2.Count, 3) = Application.Index(dic2.items, 0, 0) End With End Sub  

خيار آخر قد يكون أسرع 
Sub test() Dim i As Integer Dim r As Range: Dim tr As Range With ActiveSheet For i = 1 To .UsedRange.Rows.Count + 2 If Trim(.Cells(i, 3)) = "تعديل" Then If r Is Nothing Then Set r = .Rows(i) Else Set r = Union(r, .Rows(i)) End If End If Next i r.Delete End With End Sub  

ربما
Sub test() Dim r& With ActiveSheet r = .Cells(Rows.Count, 4).End(xlUp).Row .Range("D4:I" & r).SpecialCells(4).Delete Shift:=xlUp .Range("$D$3:$D$" & r).RemoveDuplicates 1, 1 End With End Sub  

عليكم السلام
ربما (يدون كود)
 
تجارب نقل جديد.xlsx
أو كود
Sub test() Dim a Dim i& With Sheets("sheet1") a = .Cells(2, 3).Resize(.Cells(Rows.Count, 3).End(xlUp).Row - 1, 26) End With For i = 1 To UBound(a) a(i, 4) = WorksheetFunction.Ceiling(a(i, 4), 500) Next With Sheets("sheet2") .Cells(2, 1).Resize(UBound(a), 3) = Application.Index(a, Evaluate("row(1:" & UBound(a) & ")"), Array(1, 26, 4)) End With End Sub  

عليكم السلام ورحمة الله وبركاته 
ما رأيك بكود
Sub test() Dim a Dim i&, ii& Dim sh As Worksheet For Each sh In Worksheets ii = 1 a = sh.Cells(1).CurrentRegion ReDim b(1 To UBound(a), 1 To UBound(a, 2)) For i = 2 To UBound(a) If a(i, 2) <> "" Then b(ii, 1) = a(i, 1): b(ii, 2) = a(i, 2) ii = ii + 1 End If Next sh.Cells(2, 11).Resize(ii, 2) = b Next End Sub  
ورقة عمل Microsoft Excel جديد (2).xlsm

حسب الصورة
عسى
Sub Test() Dim i& For i = 2 To Range("A" & Rows.Count).End(xlUp).Row If Cells(i, 1).Interior.Color = vbYellow Then Cells(Range("B" & Rows.Count).End(xlUp).Row + 1, 2).Value = Cells(i, 1).Value Next End Sub  
Book1.xlsm

عذراً
خطأ طباعي
Book1.xlsm

بالاذن من الاستاذ Lionheart
بنفس الطريقة 
Sub test1() Dim a Dim r As Range Dim frA Dim x& With Sheets(1) a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells End With x = 1 With Sheets("ÇáÌÏæá") Set r = Range("B:B").Find("ÇáÑÞã", , , , 1) frA = r.Address If Not r Is Nothing Then Do r.Offset(1).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "") x = x + 10 Set r = .Range("B:B").FindNext(r) Loop Until frA = r.Address End If End With End Sub وخيار آخر يعتمد على عدد الاسطر وافراغات التي يجب أن تكون متساوية في كل الشيت
Sub test2() Dim a Dim r As Range Dim frA Dim x&, i&, ii& With Sheets(1) a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells End With x = 1 With Sheets("الجدول") For i = 1 To UBound(a) Step 10 .Cells(4 + ii * 20, 2).Select .Cells(4 + ii * 20, 2).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "") x = x + 10 ii = ii + 1 Next End With End Sub المرفق مع الخيارين
 
sabah.xlsm

ربما
 
تصفية.xlsm

وعليكم السلام
ربط خليتين.xlsm

ترحيل السلة.xlsm

كود
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range("A4:A3000")) Is Nothing Then With Target .Offset(, 5).Value = Format(Date, "YYYY/MM/DD") .Offset(, 6).Value = Format(Time, "hh: mm") End With End If End Sub  

تفضل أخي الكريم
Private Sub TextBox3_Change() TextBox4 = IIf(TextBox1 = "", 1, TextBox1) * IIf(TextBox2 = "", 1, TextBox2) * IIf(TextBox3 = "", 1, TextBox3) End Sub Private Sub TextBox2_Change() TextBox4 = IIf(TextBox1 = "", 1, TextBox1) * IIf(TextBox2 = "", 1, TextBox2) * IIf(TextBox3 = "", 1, TextBox3) End Sub Private Sub TextBox1_Change() TextBox4 = IIf(TextBox1 = "", 1, TextBox1) * IIf(TextBox2 = "", 1, TextBox2) * IIf(TextBox3 = "", 1, TextBox3) End Sub بالنسبة لـ 0.25*0.23*0.26 يضرب تماما
ولكن اعتقد انه يجب عند كتابة الرقم  تبدأ بـ 0 تم . ثم بقية الرقم

وعليكم السلام
ربما
 
مخزن 2023.xls

هذا الكود يقوم بتفح ورقة جديدة على حسب المكتوب في AM14 
المطلوب ان يقوم بقفل و حماية هذه الورقة الذي يقوم بفتحها لعدم العبث او تخريب البيانات بها
Sub CopySheet() Dim strName As String, Sh As Worksheet strName = Trim(Sheet4.Range("am14").Value) For Each Sh In Worksheets If Sh.Name = strName Then Exit Sub Next Sh Sheet4.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = strName ActiveSheet.Protect "password" ' ضع كلمة السر بدل password With Sheets(strName) .Shapes("Button 1").Delete With .Range("b10:am1009") .Value = .Value End With End With Sheets("الشاشة الرئيسية").Select Range("A1").Select End Sub