الـعيدروس

السلام عليكم
الاخ الفاضل خالد القدس
خلية التحكم بإسم الشيت A1
جرب هذا الكود

Private Sub Worksheet_Change(ByVal Target As Excel.Range) Const S_N_ALI As String = "A1" Const S_ERR As String = "تسمية خاطئة " Dim S_NAM As String With Target If Not Intersect(.Cells, Range(S_N_ALI)) Is Nothing Then S_NAM = Range(S_N_ALI).Value If Not S_NAM = "" Then On Error Resume Next Me.Name = S_NAM On Error GoTo 0 If Not S_NAM = Me.Name Then MsgBox S_ERR & S_N_ALI End If End If End With End Sub

وهذا المرفق
CH_N_SH.rar

السلام عليكم

جرب المرفق
فورم إضافة بيانات أفقيا_A3.rar

السلام عليكم

جربت ارفاق الصورة في فورمه
وعمل الكود دون اي مشاكل

وهذا المرفق

أرجو التجربه
فورم مخصص_A6.rar

السلام عليكم

تفضل
اعداد تقارير مدرسية_A.rar

كما اشار استاذنا الحبيب احمد زمان
بإمكانك استخدام التصفية 
او في حالة ملفك بشكلة الحالي وعدد الاسطر
بالامكان استخدام هذا التعديل
Sub MUTAKHEEN_ALL() Dim FS As Worksheet, TS As Worksheet Dim ER, FSN, FR, TR, A, Rw Dim Rn As Range Dim Rng As Range Set App = WorksheetFunction Set TS = Sheets("تأخير") TS.Range("A6:S500").Clear TR = 6 For FSN = 1 To Sheets.Count Set FS = Sheets(FSN) If FS.Name = TS.Name Then GoTo 9 With FS On Local Error Resume Next A = App.Match(.Name, TS.Range("J:J"), 0) If Err <> 0 Then If App.CountIf(.Range("N:N"), "<0") = 0 Then GoTo 9 Rw = TS.Cells(TS.Rows.Count, "J").End(xlUp).Row + 1 TS.Rows(2).Copy TS.Range("A" & Rw) TS.Range("A3:Q5").Copy TS.Range("A" & Rw + 1).PasteSpecial xlPasteFormats TS.Range("A" & Rw + 1).PasteSpecial xlPasteValues TS.Range("J" & Rw + 1).Value = .Name Err.Clear End If TR = App.Match(.Name, TS.Range("J:J"), 0) + 3 For FR = 5 To 999 If .Cells(FR, 14) < 0 Then For FC = 1 To 17 If Not IsNull(TS.Cells(TR, FC).Borders.Value) Then TS.Cells(TR, FC).Borders.Weight = xlThin TS.Cells(TR, FC) = .Cells(FR, FC) Next FC TS.Cells(TR, 19) = .Name TR = TR + 1 End If Next FR Set Rn = TS.Range("B" & Rw + 1 & ":Q" & TR - 1) If Rng Is Nothing Then Set Rng = TS.Range("B3:Q" & TR - 1) Else Set Rng = Union(Rng, Rn) End If End With 9 Next FSN If Not Rng Is Nothing Then With TS.PageSetup .PrintArea = Rng.Address .CenterHorizontally = True .CenterVertically = False .Orientation = xlLandscape TS.PrintPreview End With End If Set TS = Nothing: Set FS = Nothing: Set App = Nothing Set Rn = Nothing: Set Rng = Nothing End Sub  

تفضل شرح مبسط في الكود
تم انشاء جدول الذي اسمة الجدول3 في الشيت
A_2.xlsm

جرب هذا الكود
بعد اذن الاساتذه الافاضل
Dim Ar() Dim i Private Sub Merg_Ali() Dim C As Range Dim A As String Dim B Sp False Erase Ar: i = 0 For Each C In ActiveSheet.UsedRange.Cells If C.MergeCells Then If i >= 1 Then If Ar(1, i) = C.MergeArea.Address Then GoTo nx End If i = i + 1 ReDim Preserve Ar(1 To 2, 1 To i) A = C.MergeArea.Address: B = C.Value Ar(1, i) = A: Ar(2, i) = B nx: C.UnMerge End If Next Sp True If i Then Ar = Application.Transpose(Ar) End Sub Private Sub Ad(A) Sp False For x = LBound(A, 1) To UBound(A, 1) Range(A(x, 1)) = A(x, 2) Next Sp True End Sub Sub Ali_Mr() Merg_Ali If i Then Ad Ar: Erase Ar: i = 0 End Sub Private Function Sp(Bl As Boolean) With Application .ScreenUpdating = Bl .EnableEvents = Bl End With End Function  

السلام عليكم
جرب المرفق ان شاء الله يفي بالغرض
 
برنامج المعتمرين _A2.xlsm

السلام عليكم
الصق هذا الكود في حدث الفورم
Private Sub UserForm_Activate() If ActiveSheet.Name <> "data" Then Me.Hide Sheets("data").Activate saad1.Show End If End Sub  

السلام عليكم
جرب المرفق على الرابط التالي
اكيد مع حجم البيانات الكبير بيكون بطيئ
ملاحظة بسيطة على ملفك تنسيق الشيت كامل يسبب بطئ في الملف
يفضل عمل بوردر فقط لمدى البيانات وليس للشيت كامل
 
 
2020_A.xlsm

السلام عليكم
انشأت اوراق لأشهر وهمي
يشترط اذا ضفت اوراق اخرى لاشهر تسميها بنفس الطريقة 
وعمود ارقام الايام في Sheet1 تسجل التاريخ لليوم وليس ارقام الايام
كود بسيط اضافة الى حلول الاساتذه الافاضل
تفضل المرفق
 
 
 
ترحيل بيانات_1.xls

السلام عليكم
تفضل
Private Sub CommandButton1_Click() Dim c, ii, i Dim Tx As Control ii = 0 For i = 1 To 4 If TypeOf Me.Controls(i) Is MSForms.TextBox Then c = Me.Controls(i) = "": If c Then ii = ii + 1 End If Next If ii Then MsgBox ("لا يمكن الارسال بعض الحقول فارغه ") Else MsgBox ("تم الاسال ") End Sub  

السلام عليكم
تفضل المرفق 
تحكيم1.xlsm

السلام عليكم
استخدم هذا الكود
Private Sub Copy_Filtr(wb As Workbook, ws As Worksheet, Rng As Range, Optional sFile As String) Dim Pth Dim N_Book As Workbook Pth = ActiveWorkbook.Path & Application.PathSeparator If IsFile(Pth & sFile & ".xlsx") Then MsgBox "الملف موجود مسبقاً بنفس الاسم" & vbCrLf & "اعد المحاولة بأسم اخر" Exit Sub End If Set N_Book = Workbooks.Add wb.Sheets(ws.Name).Range(Rng.Address).Copy With N_Book With .Sheets(1) .Range("a1").PasteSpecial (xlPasteAll) .UsedRange.Columns.AutoFit End With .SaveAs FileName:=Pth & sFile & ".xlsx" .Close End With End Sub Private Function IsFile(ByVal fName As String) As Boolean If Dir(fName, vbDirectory) <> vbNullString Then IsFile = True Else IsFile = False End If End Function Sub My_Fl() Application.DisplayAlerts = False With ActiveWorkbook.ActiveSheet Dim lRow, Cl, On_R Cl = Split(.UsedRange.Address, "$")(3) On_R = Split(.UsedRange.Address, "$")(1) & "1:": lRow = Split(.UsedRange.Address, "$")(4) With .Range(On_R & Cl & lRow) Copy_Filtr ActiveWorkbook, ActiveSheet, .SpecialCells(xlCellTypeVisible), "My_Filtr3" End With End With End Sub  

السلام عليكم
اذهب خيارات الاكسل ثم مركز التوثيق ثم اعدادات مركز التوثيق
ثم خيارات الخصوصية زيل المؤشر اذا محفز

المعطيات المسار واسم الجدول 
تفضل المرفق
البحث في جدول6 .xlsm

السلام عليكم
مالمراد بهذا هل تريد الملفات التي
لم يحصل ان تم فتحها لفترة زمنية تحذف
اذا كان هكذا ممكن اضافة وظيفة تشتغل كل ماتم فتح 
برنامج الاكسل وتروح تشييك على المجلد او الملف المعني
اذا وجدت الملف لم يحصل عليه تعديل مثلا لاكثر
من اسبوعين او ايام يقوم بحذفه
شوف بالكود التالي حدد عدد الايام في بداية الكود
وحط مسار الملف المعني وحفظ ملف الكود بصيغة Excel Add-In
بعد حفظه روح خيارات الاكسل  , الوظائف الاضافية انتقال وحفز
على الملف Addin الذي به الكود 
وكل مافتحت برنامج الاكسل بيشتغل الكود ويشيك على تاريخ التعديل
للملف المعني اذا وجد تاريخ اخر تعديل اكبر من التاريخ الحالي بالزمن المحدد يحذفه
ويشعرك برسالة ان تم حذف الملف
 
Sub Auto_open() My_Kill End Sub Sub My_Kill() ' عدد الايام الافتراضية Const Day_Kil As Integer = 4 Const Path_My_File As String = "C:\Users\abdulrhman\Desktop\سطح سابق\" & "33232323.xlsb" Dim File_Date Dim Date_Now Dim A If Chk_My_File(Path_My_File) Then File_Date = My_File_Edt(Path_My_File) Date_Now = Now() A = DateDiff("d", File_Date, Date_Now) If A > Day_Kil Then Kill Path_My_File MsgBox " تم حذف الملف المعني لم يفتح خلال المدة المحددة " & Path_My_File End If End If End Sub Private Function Chk_My_File(Fil_Name) As Boolean Dim x As String x = Dir(Fil_Name) If x <> "" Then Chk_My_File = True Else Chk_My_File = False End Function Function My_File_Edt(My_File_Name As String) Dim fs As Object, f As Object, s As String Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFile(My_File_Name) My_File_Edt = f.DateLastModified Set fs = Nothing: Set f = Nothing End Function  

عفوا هذا ملفك مفعل به شاشة الدخول
برنامج شركة 1السما للنقل والتوريدات.xlsm

السلام عليكم
بالامكان حسب فهمي لطلبك
بكود حدث الصفحة كالتالي
' استبدل مدى الاعمدة حسب مدى بيانات الكنترول لديك Private Const Adrss = "A:Z" Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range(Adrss)) Is Nothing Then With Target .Offset(0, 1).Select If Split(Adrss, ":")(1) = Split(.Address, "$")(1) Then Range(Split(Adrss, ":")(0) & .Row + 1).Select End If End With End If End Sub  

السلام عليكم
خطأ فقط استبدل + بعلامة الفاصله المنقوطة ; واذا كان لديك بالويندوز الفاصلة العاديه استخدمها ,
معادلة S15
=MOD( SUM( H6;J6;L6;N6;P6;D9;F9;H9;J9;L9;N9;P9;D12;F12;H12;J12;L12;N12);100) معادلة T15
=SUM(I6;K6;M6;O6;Q6;E9;G9;I9;K9;M9;O9;Q9;E12;G12;I12;K12;M12;O12)+INT(SUM(H6;J6;L6;N6;P6;D9;F9;H9;J9;L9;N9;P9;D12;F12;H12;J12;L12;N12)/100)  

السلام عليكم
الخلايا التي بها الوان متدرجه لايجدي الكود معها
لاكن بخصوص اختلاف ارجاع الالوان كما سابقتها
بالامكان تصحيحه بالتعديل على الكود ليصبح كالتالي
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) MyColor = 6 If Not IsError(Sh.[N_Color_Rng]) Then If Not IsError(Sh.[N_Color_Color]) Then If Not IsError(Sh.[N_Color_Old]) Then If Sh.[N_Color_Rng].Interior.ColorIndex = Sh.[N_Color_Old] Then Dim R, G, B R = Ref_Ali(Sh.Names("N_Color_Color").RefersToR1C1, 1) G = Ref_Ali(Sh.Names("N_Color_Color").RefersToR1C1, 2) B = Ref_Ali(Sh.Names("N_Color_Color").RefersToR1C1, 3) Sh.[N_Color_Rng].Interior.Color = RGB(R, G, B) End If End If End If End If Sh.Names.Add "N_Color_Rng", ActiveCell Sh.Names.Add "N_Color_Color", G_Colr(ActiveCell) Sh.Names.Add "N_Color_Old", MyColor ActiveCell.Interior.ColorIndex = MyColor End Sub Function Ref_Ali(a, Inx) Select Case Inx Case 1 aa = Mid(a, InStr(1, a, "(") + 1, InStr(InStr(1, a, "("), a, ",") - InStr(1, a, "(") - 1) Case 2 aa = Split(a, ",")(1) Case 3 aa = Mid(Trim(Split(a, ",")(2)), 1, InStr(1, Trim(Split(a, ",")(2)), ")") - 1) End Select Ref_Ali = aa End Function Function G_Colr(Rng As Range) Dim HEX_A As String Dim Ali_R As String HEX_A = Right("000000" & Hex(Rng.Interior.Color), 6) Ali_R = "RGB (" & CInt("&H" & Right(HEX_A, 2)) & ", " & CInt("&H" & Mid(HEX_A, 3, 2)) & ", " & CInt("&H" & Left(HEX_A, 2)) & ")" G_Colr = Ali_R End Function  

السلام عليكم
تفضل
D_n.xlsm

السلام عليكم
بهذا الكود
Private Sub CommandButton1_Click() Dim pth, Nm pth = "D:\my_f\" Nm = Me.ComboBox1.Value & ".*" If Dir(pth & Nm, vbDirectory) = "" Then MsgBox "لايوجد ملف بنفس الاسم بالمسار المحدد لحذفه" Else Kill pth & Nm & ".*" MsgBox "تم حذف الملف بنجاح" End If End Sub  

السلام عليكم
جرب هذا التعديل 
 
2009(3).xlsm

نفس الكود
انا بملفي فقط حطيت تجاوز الحقلين التي بتكتب عليهم الارقام
لاجل لايعتمدو ضمن الحلقة التكرارية
Private Sub CommandButton1_Click() Dim i As Integer Dim x As Integer Dim z As Integer Dim Tx As Control x = CInt(TextBox1.Text) z = CInt(TextBox2.Text) For i = x To z If TypeOf Me.Controls(i) Is MSForms.TextBox Then Me.Controls(i + 2).Text = i End If Next i End Sub او كالتالي عداد خاص للترميز للحقول البقية
Private Sub CommandButton1_Click() Dim i As Integer Dim x As Integer Dim z As Integer Dim C Dim Tx As Control x = CInt(TextBox1.Text) z = CInt(TextBox2.Text) C = 3 For i = x To z If TypeOf Me.Controls(C) Is MSForms.TextBox Then Me.Controls(C).Text = i C = C + 1 End If Next i End Sub