الـعيدروس

السلام عليكم تفضل اخي ياسر A_Cun.rar

السلام عليكم فكرة جميلة كـ جمال روحك اخي أبو حنين تقبل مروري

السلام عليكم Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) If WorksheetFunction.CountIf([A1:A20], TextBox1) = 0 Then TextBox1 = "": Exit Sub End Sub

السلام عليكم جرب هذا الكود في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 5 Or Target.Row < 10 Then Exit Sub If Target = "" Then Exit Sub Range(Cells(Target.Row, 1), Cells(Target.Row, 13)).Borders.ColorIndex = 1 End Sub

جرب هذ التعديل أتمنا أن اكون فهمت طلبك Public Sub Tr_A() Dim Sn As Worksheet, Sh As Worksheet Dim L_r&, rw& Dim Rn As Range, R& Set Sn = Sheets("البيانات") Set Sh = Sheets("البيانات العملاء المسددين") With Application .ScreenUpdating = False .EnableEvents = False L_r = Sn.Cells(Rows.Count, 3).End(xlUp).Row For R = L_r To 15 Step -1 If Sn.Cells(R, 45).Value = 0 Then With Sh rw = .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row With Sn.Range(Sn.Cells(R, 4), Sn.Cells(R, 45)) .Copy Sh.Cells(rw, 2).PasteSpecial xlPasteValues With Sn Union(.Cells(R, 7), .Cells(R, 8), .Cells(R, 9), .Cells(R, 10), .Cells(R, 11), .Cells(R, 12), _ .Cells(R, 13), .Cells(R, 17), .Cells(R, 19), .Cells(R, 20), .Cells(R, 21), .Cells(R, 23), _ .Cells(R, 25), .Cells(R, 27), .Cells(R, 29), .Cells(R, 31), .Cells(R, 33), .Cells(R, 35), _ .Cells(R, 37), .Cells(R, 39), .Cells(R, 41), .Cells(R, 43)).ClearContents End With End With Application.CutCopyMode = False End With End If Next With Sn.Rows("15:" & Sn.Cells(Rows.Count, 4).End(xlUp).Row) .Sort Key1:=Sn.Cells(15, 5), Order1:=xlDescending, Header:=xlNo End With .EnableEvents = True .ScreenUpdating = True End With End Sub

السلام عليكم جرب هذا الكود واعتقد انه يلزم حذف الصفوف الرحله ؟ Public Sub Tr_A() Dim Sn As Worksheet, Sh As Worksheet Dim L_r&, rw& Dim Rn As Range, R As Range Set Sn = Sheets("البيانات") Set Sh = Sheets("البيانات العملاء المسددين") With Application .ScreenUpdating = False .EnableEvents = False L_r = Sn.Cells(Rows.Count, 3).End(xlUp).Row Set Rn = Sn.Range(Sn.Cells(15, 45).Address, Sn.Cells(L_r, 45).Address) For Each R In Rn If R.Value = 0 Then With Sh rw = .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row Sn.Range(Sn.Cells(R.Row, 4), Sn.Cells(R.Row, 45)).Copy .Cells(rw, 2) Application.CutCopyMode = False End With End If Next .EnableEvents = True .ScreenUpdating = True End With Set R = Nothing: Set Rn = Nothing End Sub

السلام عليكم جرب هذا الكود في حدث الورقة Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, [C:C,D:D,E:E,F:F]) Is Nothing Then L_a = Cells(Rows.Count, "J").End(xlUp).Row Cells(L_a, "J") = Val(Target) Cells(L_a + 1, "J") = WorksheetFunction.Sum(Range(Cells(1, "J"), Cells(L_a, "J"))) Cancel = True End If End Sub

السلام عليكم جزاك الله خير اخي أبو حنين على أعمالك والنشاط المستمر أستاذنا الكبير أحمد زمان سلمت يمناك على الملف الأكثر من رائع وبارك الله فيك وجزاك كل خير تقبلو مروري

السلام عليكم بعد اذن اخي الحبيب أحمد فضيله استبدل كود حدث الورقة بالتالي Private Row_A As Integer Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row = 7 And Target.Column = 4 Then On Error Resume Next Dim A_r With Sheet3 .Range("aa11:aa5555").AutoFilter Field:=1, Criteria1:="=" & .[k10] If .AutoFilterMode = False Then Row_A = .Range("E65536").End(xlUp).Offset(1, 0).Row Else With .AutoFilter.Range Row_A = .Row + .Rows.Count End With End If With .Range(.Cells(4, 2), .Cells(Row_A, 5)) .Select A = .Address End With .ResetAllPageBreaks .PageSetup.PrintArea = "" .PageSetup.PrintTitleRows = "$4:$10" .PageSetup.PrintArea = A .Range("aa11:aa5555").Rows.AutoFit .PrintPreview End With End If End Sub طباعة.xlsm_A.rar

السلام عليكم بعد اذن الاخ الفاضل Creation World والذي اشكرة على الملف القيم والأكثر من رائع تفضل اخي Khhanna Public Sub Ali_Scrol() With ActiveSheet Activewindow.DisplayWorkbookTabs = False ' False = إخفار الأوراق ' True = الوضع الطبيعي .ScrollArea = "$A$2:$C$25" ' فرضاً المدى المراد تحديدة فقط هو End With End Sub

السلام عليكم جرب هذا الكود فرضا أن مدى البيانات من العمود A الى العمود C Public Sub Ali_Page() Dim S As Long With ActiveSheet On Error Resume Next S = .HPageBreaks(1).Location.Row If S = 0 Then Exit Sub .ResetAllPageBreaks .PageSetup.PrintArea = "" .PrintTitleRows = "$1:$1" .PageSetup.PrintArea = .Range(.Cells(1, "A"), .Cells(S - 1, "C")).Address .PrintPreview End With End Sub

السلام عليكم اضغط الملف بأحد برامج الضغط WinRAR أوا WinZip ثم ارفقة

السلام عليكم جرب هذا الكود Sub A_Copy() Dim W As Workbook Set W = Workbooks.Add(xlWorksheet) ThisWorkbook.Sheets(1).Copy W.Sheets(1) End Sub

تفضل جرب هذا التعديل Sub Trheel1() With Application .ScreenUpdating = False .EnableEvents = False For R = [A10000].End(xlUp).Row To 3 Step -1 For C = 1 To 16 If Cells(R, C).Interior.ColorIndex <> xlNone Then Range(Cells(R, 1), Cells(R, 16)).Copy _ Sheets("المناقلات المنتهية").Range("A" & Sheets("المناقلات المنتهية").[A10000].End(xlUp).Row + 1) Cells(R, 1).EntireRow.Delete End If Next Next .ScreenUpdating = False .EnableEvents = False End With End Sub

الكود هذا عمله يقوم بالتشييك على الاعمدة من A الى J اذا اين منم به لون يرحل الصف الى الورقة 2

الاخ ابو ردينه هذا متغير مصفوفة لمدى البيانات من العمود 1 الى اخر عمود المحدد في بداية الكود ContColmn = 6 ReDim x(1 To ContColmn)

السلام عليكم اذا الكان الشرط للتنسيق الشرطي للمدى المحدد هو "Holiday" فهذا التعديل للداله بيزبط معك ان شاء الله Public Function Ali_Cond(ByVal My_r As Range, Cond As String, Nu_Colr As Long) As Long Dim R As Range Dim Ali_c As FormatConditions Dim A_Dou As Double Application.Volatile A_Dou = 0 For Each R In My_r Set Ali_c = R.FormatConditions Select Case Ali_c(1).Interior.ColorIndex Case Is = Nu_Colr And IIf(Cond = "", R.Offset(0, 1) = "Holiday" Or R.Offset(0, 2) = "Holiday", R.Text > "") A_Dou = A_Dou + 1 End Select Next Ali_Cond = A_Dou End Function

السلام عليكم الاستاذ الكبير عبدالله باقشير صدقني كنا بإنتظار مشاركتك لان أعمالك فريده من نوعها واكواد متقنه مختصره تنم عن خبره جزاك الله كل خير وبارك فيك

الاخ ابو تميم اذهب الى اعدادات الاكسل ثم مركز التوثيق ثم إعدادات مركز التوثيق ثم اعدادت الماكرو ثم حفز مربع الثقة في الوصول إلى طراز كائن مشروع VBA ثم جرب الكود

الطلب غير واضح كيف فلترة اتوماتك ماهو الشرط ؟ ماهي القيمة المراد عمل عليها فلترة وفي أي عمود وهل تقصد اتوماتك يعني عند فتح المصنف ام عند كل تغير في الورقة

الاخ ابو تميم هذا الجزء من الكود Ar = Array("{0002E157-0000-0000-C000-000000000046}", "{94A0E92D-43C0-494E-AC29-FD45948A5221}") الاول رمز اضافة مكتبة للتعامل مع زاجهة Reference والرمز الثاني لإضافة مكتبة Wi حق الاسكنار أرجو أن تكون اتضحت لديك الصورة

السلام عليكم الاخ الحبيب ياسر خليل بعد اطلاعي على مرفقك حقيقة ملف قيم حستفيد منه كثير جزاك الله كل خير

السلام عليكم الاخ الحبيب سعد عابد الخلوق جدا اشكرك جد على كلماتك المشجعه وشعورك الطيب السموحه على التأخير إطلع على المرفق امل أن يكون المطلوب وأي إضافات أو تعديل أنا في الخدمه تقبل تحياتي وشكري فاتورة_Sad_Aabd.rar

السلام عليكم بعد اذن اخي الفاضل ياسر خليل هذا الكود استخدمه في حدث فتح الملف Private Ar Private Sub Workbook_Open() Dim Ref For Each Ref In ThisWorkbook.VBProject.References If Ref.IsBroken = True Then ThisWorkbook.VBProject.References.Remove Ref Next Ref Ali_Referen End Sub Private Function Ali_Referen() Dim Ai&, A_Rw$ On Error Resume Next Ar = Array("{0002E157-0000-0000-C000-000000000046}", "{94A0E92D-43C0-494E-AC29-FD45948A5221}") For Ai = LBound(Ar) To UBound(Ar) A_Rw = Ar(Ai) ThisWorkbook.VBProject.References.AddFromGuid GUID:=A_Rw, Major:=1, Minor:=0 Next Ai End Function جرب الكود وبلغنى بالنتائج

كلامك سليم يوجد خلل في الشرط احاول معها عسى ان تزبط