الـعيدروس

ولك مثل دعائك اضعاف ان شاء الله وهكذا للاعمدة والصفوف حسب الصوره وتوضيحك Sub C_r() With ActiveSheet .Columns("G" & ":" & Chr(105) & Chr(117)).EntireColumn.Hidden = True .Rows("1001" & ":" & .Rows.Count).EntireRow.Hidden = True End With End Sub

بيكون كالتالي Sub Ar() Rows("1001" & ":" & Rows.Count).EntireRow.Hidden = True End Sub

السلام عليكم اكتب رقم الفصل او رقم اللجنه المراده في الخلايا الصفراء Sa.rar

بيكون هكذا مجرد الادخال في عمود النوع اذا حطينا الادخال في عمود الفصل كيف سيرحل مابعده وهو النوع ؟ اذا الترحيل سيتم بعد الانتهاء من ادخال بيانات الاعمده " اخر عمود هو النوع " Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [H14:H10000]) Is Nothing Then Dim Sh As Worksheet For Each Sh In ThisWorkbook.Worksheets With Target If Right(.Offset(0, -2), 1) & "-" & Left(.Offset(0, -2), 1) = Sh.Name Then Lr = Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row .Offset(0, -7).Resize(1, 8).Copy Sh.Range("A" & Lr).PasteSpecial xlPasteValues End If End With Next Application.CutCopyMode = False End If End Sub

بمودويل Sub A() [G1:IU1].EntireColumn.Hidden = True End Sub

السلام عليكم تفضل form_size_A1.rar

السلام عليكم حط هذا الكود في حدث ورقة " الصف الثاني " مجرد الكتابه في عمود اللجنه يرحل الصف الى الورقة المماثله لرقم الفصل Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [I14:I10000]) Is Nothing Then Dim Sh As Worksheet For Each Sh In ThisWorkbook.Worksheets With Target If Right(.Offset(0, -3), 1) & "-" & Left(.Offset(0, -3), 1) = Sh.Name Then Lr = Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row .Offset(0, -8).Resize(1, 9).Copy Sh.Range("A" & Lr).PasteSpecial xlPasteValues End If End With Next Application.CutCopyMode = False End If End Sub

اخفاء من اخر عمود للجدول الى اخر عمود للورقة [G1:IU1].EntireColumn.Hidden = True

كلا الشرطيين التحقق على أي عمود على الـ "F" أو "E" ؟

لايوجد شرح للمطلوب في الملف ؟ ماهي الأعمدة المراد ترحيلها وإلى أي مدى متجاور ؟؟

السلام عليكم جرب المرفق T_Ed.rar

كما تفضل اخي حماده عمر إرفق مثال

السلام عليكم إطلع على المرفق form_size_A.rar

الحمد لله الذي بنعمته تتم الصالحات مانطرحه في هذا المنتدى انما هو رد للدين الذي علينا وهو العلم الذي اكتسبناه منه

اخي احمد حبيب في حال الماكرو غير مفعل لن تستطيع تشغيل ماكرو والفورم برضه يعمل عن طريق ماكرو اذا لايمكن فتح فورم والماكرو غير مفعل

جرب هذا التعديل Private Sub Worksheet_Change(ByVal T As Range) On Error Resume Next Static Val_A As Double Static Val_B As Double With T If Not Intersect(T, [B3]) Is Nothing Then If Not IsEmpty(.Value) And IsNumeric(.Value) Then _ Val_A = Val(.Offset(0, -1)) - Val(.Value) Else: Val_A = 0 Application.EnableEvents = False .Offset(0, -1).Value = Val_A Application.EnableEvents = True End If End With If Not Intersect(T, [B1:T1]) Is Nothing Then With T If Not IsEmpty(.Value) And IsNumeric(.Value) Then _ Val_B = Val([A1]) - WorksheetFunction.Sum([B1:T1]) Else: Val_B = 0 Application.EnableEvents = False [A1].Value = Val_B Application.EnableEvents = True End With End If End Sub

الطلب الاول محدد على الصف المحدد فقط

السلام عليكم حط هذا الكود في حدث الورقة Private Sub Worksheet_Change(ByVal T As Excel.Range) On Error Resume Next Static Val_A As Double With T If Not Intersect(.Value, [B3]) Is Nothing Then If Not IsEmpty(.Value) And IsNumeric(.Value) Then _ Val_A = Val(.Offset(0, -1)) - Val(.Value) Else: Val_A = 0 Application.EnableEvents = False .Offset(0, -1).Value = Val_A Application.EnableEvents = True End If End With End Sub جرب وبلغنى بالنتائج

السلام عليكم حسب معطاياتك تحديد اعدة معينه طال الكود حبتين إن شاء الله يعمل معك جرب المرفق Ad_3.rar

ورقة الصندوق غير موضح فيها الإيراد من أي مشترك والمصروف برضه لو يضاف في الجدول عمود إسم المشترك واذا المصروف على حساب المبنى ليس على المشترك تضيف حساب مصروفات عامه مثلا كي يتسنى معرفة حركة المشتركين والحسابات لعمل تقارير بموجبها

جرب هكذا Private Const Msg As String = "أولا إدخال البيانات في عمود A" Private Const Til As String = "تنبية " Private Sub Worksheet_Change(ByVal T As Excel.Range) With Application .EnableEvents = False If Not Intersect(T, [B:B]) Is Nothing Then If T.Offset(0, -1) = "" Then MsgBox Msg, vbExclamation, Til: T.Clear: Exit Sub If Not Intersect(T, [C:C]) Is Nothing Then If T.Offset(0, -2) = "" Then MsgBox Msg, vbExclamation, Til: T.Clear: Exit Sub If Not Intersect(T, [D:D]) Is Nothing Then If T.Offset(0, -3) = "" Then MsgBox Msg, vbExclamation, Til: T.Clear: Exit Sub .EnableEvents = True End With End Sub

اذا لم تضاف الاداة الى القائمة جرب الكود التالي وإن شاء الله تجدها محفزه والكود حيعمل ان شاء الله Public Sub Ad_Refe() On Error Resume Next With ThisWorkbook.VBProject.References .AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL" .AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB" .AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL" .AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB" End With End Sub

جرب هذا التعديل انسخ الكود في في مودويل ثم احفظ الملف وافتحه مره اخر واذهب لقائمة References وتأكد من الجمله انها موجوده ومحفز عليها اذا تفعلت جرب الكود Sub Auto_open() On Error Resume Next ActiveWorkbook.VBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 0, 0 End Sub Public Sub Ali_AddB() Dim S$, C, T, i, ii Dim Sh As Shape Dim Op As VBComponent Dim Opj As VBComponent T = 1 On Error Resume Next For Each Sh In ActiveSheet.Shapes If Not Sh.Type = msoShapeRectangle Then Sh.Delete End If Next If IsError(Op) = False Then Else GoTo 0 Set Op = ActiveWorkbook.VBProject.VBComponents("A_Mod") ActiveWorkbook.VBProject.VBComponents.Remove Op 0: Set Opj = ActiveWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule) Opj.Name = "A_Mod" For i = 1 To Sheets.Count If Sheets(i).Name = ActiveSheet.Name Then GoTo 1 With Opj.CodeModule C = .CountOfLines + 1 .InsertLines C, "Sub my_" & i & "()" & Chr(13) & _ " Sheets(" & i & ")" & ".Select" & Chr(13) & "End Sub" End With ActiveSheet.Buttons.Add(Cells(1, 1).Left, T, 89.25, 23.25).Select S = Selection.Name Selection.Caption = Sheets(i).Name Selection.OnAction = "my_" & i T = T + 24 1 Next End Sub

السلام عليكم الكود في حدث الورقة Private Const Msg As String = "أولا إدخال البيانات في عمود A" Private Const Til As String = "تنبية " Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [B:B]) Is Nothing Then If Target.Offset(0, -1) = "" Then MsgBox Msg, vbExclamation, Til: Exit Sub If Not Intersect(Target, [C:C]) Is Nothing Then If Target.Offset(0, -2) = "" Then MsgBox Msg, vbExclamation, Til: Exit Sub If Not Intersect(Target, [D:D]) Is Nothing Then If Target.Offset(0, -3) = "" Then MsgBox Msg, vbExclamation, Til: Exit Sub End Sub

اخي الحبيب سعد عابد وأنا ايضا أسعد بمروك الرائع دوماً بارك الله فيك ونور دربك تقبل تحياتي وشكري