الـعيدروس

السلام عليكم بالامكان التحقق من القيم اذا رحلت سابقاً لايرحلها كالتالي Sub trheel() Dim Cl As Range, i As Integer For i = 2 To 41 For Each Cl In Range("G3:G" & [G10000].End(xlUp).Row) If Not Ch(Cl, i) Then If Cl.Value = Sheets(i).Name Then Cl.Offset(0, -6).Resize(1, 7).Copy Sheets(i).Range("A" & Sheets(i).[A10000].End(xlUp).Row + 1) End If End If Next Next End Sub Private Function Ch(Cl As Range, i) As Boolean If Application.CountIfs(Sheets(i).Range("A3:A" & 1500), _ Range("A" & Cl.Row), Sheets(i).Range("B3:B" & 1500), _ Range("B" & Cl.Row), Sheets(i).Range("C3:C" & 1500), Range("C" & Cl.Row), _ Sheets(i).Range("F3:F" & 1500), Range("F" & Cl.Row)) = 1 Then Ch = True End Function

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

شاهد المرفق انقر دبل كليك على الخليه الصفراء واكتب رقمين في اول مربع وهكذا الذي يليه طبعا هذا مثال بالامكان تطويعه لاكثر من حاله حسب طلبك Ali_Cll.xlsm

السلام عليكم امسح البيانات بعد ترحيلها من صفحة الرئيسية Sub trheel() Dim Rng As Range Dim cl As Range, i As Integer Set Rng = Range("G3:G" & [G10000].End(xlUp).Row) For i = 2 To 41 For Each cl In Rng If cl <> "" Then If cl.Value = Sheets(i).Name Then cl.Offset(0, -6).Resize(1, 7).Copy Sheets(i).Range("A" & Sheets(i).[A10000].End(xlUp).Row + 1) End If End If Next Next If Rng.Rows.Count > 7 Then Rng.Offset(0, -6).Resize(, 7).ClearContents Set Rng = Nothing End Sub

السلام عليكم الى حل الغالي الاستاذ سليم ولاثراء الموضوع شاهد المرفق TxtBox_Tw.xlsm

السلام عليكم كليك يمين على الخلايا المعنية ثم تنسيق الخلايا

السلام عليكم يفضل ارفاق مثال

Private Sub CommandButton2_Click() If trim(EVAL.EV_Label1.Caption) = "" Then EVAL.Ev_text6.Visible = False Else EVAL.Ev_text6.Visible = True End If end sub هذا التعديل

السلام عليكم اخ حسام النتائج صحيحة الظاهر انك بتعمل على ملف اخر

او هكذا يستبدل الملف ماتم سابقاً Private Sub Copy_Filtr(wb As Workbook, ws As Worksheet, Rng As Range, Optional sFile As String) Dim Pth, My_Pth Dim N_Book As Workbook Pth = ActiveWorkbook.Path & Application.PathSeparator My_Pth = Pth & sFile 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 Application.DisplayAlerts = False .SaveAs FileName:=My_Pth & ".xlsx" .Close Application.DisplayAlerts = True End With End Sub Sub My_Fl() 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

السلام عليكم استخدم هذا الكود 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

السلام عليكم جرب المرفق دقق على عمل الفورم ان وجدت ملاحظات ارفقها وسيتم تعديلها انشاء الله في امان الله استعلام عن طريق الاسم 1.xlsm

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

السلام عليكم ملاحظة اختيار ترحيل البيانات لشيت معين هل تترحل بنفس ترتيب Sheet3 وجدول بيانات الموظفين Sheet2 هل تستخدمه ام لا

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

استخدم هذا المرفق اخفي الملف وحطه في أي موقع بالجهاز وحدد مساره بالكود وحدد اسم الورقة فقط طريقة البحث وجلب القيمة نفس طلبك السابق واذا تريد تغير صيغة البحث بالامكان تطويع الكود لأي حاله تريد البحث في جدول5 .xlsm

السلام عليكم حط معطياتك الاساسية في بداية الكود وجرب ' حط هنا مسار الملف الاساسي Private Const Pth As String = "C:\Users\user\Desktop\My_Book.xlsx" ' حط هنا اسم الورقة في الملف الاساسي Private Const Name_Sheet As String = "Sheet1" البحث في جدول4 .xlsm

السلام عليكم انقر مرتين على مربع المسار واختار الملف المراد وحدد من القائمة اسم الورقة بعدها حدد القيم المراده البحث في جدول3 .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

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

ممكن الاستفاده بهذا الفورم استخدام صفحة اساسية للطباعه ومصدر البيانات ممكن تشير له عبر الفورم والاساس جلب البيانات لصفحة الطباعه يحتاج تغير المصدر بكل مااردت تغير مصدر البيانات للطباعه في الدالات الموجود بصفحة الطباعه والفورم شاهد المرفق عدلت بحيث تحط المعطيات في بداية الكود بيان الحالة3.xlsm

السلام عليكم هذا Height ارتفاع الـ CheckBox * عدد الاسماء النتيجة نحطها ارتفاع الـ Frame2 بيان الحالة2.xlsm

وكيف تشعر الاكسل انك اتتمت الكتابة في الخلية النشطة لكي ينقلك الى التالي

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

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