الـعيدروس

السلام عليكمحط هذه الاكواد في حدث ورقة R Option ExplicitPrivate Const SH As String = "DATA"Private Const CO_T As Integer = 1Private Const CO_T1 As Integer = 2Dim RODim Var As BooleanPrivate Sub CommandButton1_Click()SSALIDROOS ' لتفعيل الكود' تخصيص زر ActivateEnd SubPrivate Sub R_SeT(M_R As String)With Application.ScreenUpdating = False.EnableEvents = FalseDim QQ%, CC%, C%Dim RR As RangeDim L_C&, SS&QQ = 16C = 1With Sheets(SH)L_C = .Cells(.Rows.Count, IIf(Var, CO_T, CO_T1)).End(xlUp).RowFor SS = 1 To L_C For CC = 2 To 17 If CStr(.Cells(SS, IIf(Var, CO_T, CO_T1))) = M_R Then Cells(CC + 14, "G").Value = .Cells(SS, CC + 2).Value Cells(9, "I") = .Cells(SS, 1).Value Cells(5, "I") = .Cells(SS, 2).Value End If C = C + 1 Next QQ = QQ + 1NextEnd With.ScreenUpdating = True.EnableEvents = TrueEnd WithEnd SubPrivate Sub ALIDROOS()Dim A As RangeDim B As RangeSet A = [D5]: Set B = [D9]If A <> Empty And B <> Empty ThenMsgBox "حدد معيار للبحث فقط", vbCritical, "تنبية !!!"ElseIf A > Empty And Not B <> Empty ThenRO = A.RowVar = TrueR_SeT A.TextElseIf B > Empty And Not A <> Empty ThenRO = B.RowVar = FalseR_SeT B.TextEnd IfEnd SubPrivate Sub SS()Select Case Var Case Is = TrueUnion(Cells(RO, 9), Cells(RO, 9).Offset(4, 0), Cells(RO, 7).Offset(11, 0).Resize(14, 1)).ClearContents Case Is = FalseUnion(Cells(RO, 9), Cells(RO, 9).Offset(-4, 0), Cells(RO, 7).Offset(7, 0).Resize(14, 1)).ClearContentsEnd SelectEnd Sub تم ارفاق الملف وبه الاكواد Q_Ali_1.rar

وفي اي حدث تريد تنفيذ جواب الشرط ؟

السلام عليكم الاستاذ الحبيب دغيدي اعتقد يلزم سطر تجاوز الاخطاء في اول الكود فقط ON ERROR RESUME NEXT

السلام عليكم هذا هو عمل الكود في حال الاضافة والحذف جرب المرفق وابلغني بالنتائج 500_A.rar

عذرا اخي يوسف لم انتبه انها Cut خاصية القص لايمكن تحديد نوع التنسيق لاكن هكذا يفي بالغرض Sheets(X).Select Range("B35:D60").Copy Range("I5").Select ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats Range("B2:D100").ClearContents Range("A1").Select

السلام عليكم تفضل Public Sub ALIDROOS_CX() Dim B% Dim A As Range Dim MR As Range Set A = [O6:O11] Set MR = [B7:J7] 'حدد المدى اذا تغير من هنا With MR Z = .End(xlToRight).Column + 1 XX = Z - (Z / 2): B = 2 For AA = 2 To XX R = Cells(100, B).End(xlUp).Offset(1, 0).Row A.Copy Cells(R, B).PasteSpecial xlPasteValues B = B + 2 Next End With End Sub

السلام عليكم تفضل Sub AAAAA() Dim R As Range Dim T%, I% With ActiveSheet I = .Cells(Rows.Count, 1).End(xlUp).Row Set R = .Range("A2:Z" & I) ' غير المدى من هنا For T = 1 To R.Rows.Count '.Rows(T).Interior.Color = RGB(245, 232, 168) ' لعمل لون للصف كامل .Range(Cells(T, 1), Cells(T, 26)).Interior.Color = RGB(245, 232, 168) ' تلوين حدود المدى T = T + 1 Next End With End Sub

السلام عليكم Sheets(X).Select Range("B35:D60").Cut Range("I5").Select ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats Range("A1").Select

ياريت تدرج بيانات في الجدول كي اعرف ماتقصده لاني ليس لدي فكره عن هذه الجداول وادخالاته وعندك جدولين في الورقة ايهما المقصود جدول المكتبه ام جدول الحاسب ؟

مزيد من التوضيح مالمقصود بااختيار ومن اين مصدر المواد والفصول هل هو يدوي الادخال ام من مدى معين توضيح لو تكرمت

السلام عليكم جرب هكذا Public Sub ALIDROOS_CC() Dim B% Dim A As Range Set A = [O6:O11] B = 2 For AA = 2 To 6 R = Cells(100, B).End(xlUp).Offset(1, 0).Row A.Copy Cells(R, B).PasteSpecial xlPasteValues B = B + 2 Next End Sub

السلام عليكم جرب هكذا Public Sub ALIDROOS_CC() Dim C% Dim A As Range Set A = [O6:O11] B = 2 For AA = 2 To 5 R = Cells(Rows.Count, AA + 2).End(xlUp).Offset(1, 0).Row A.Copy Cells(R, B).PasteSpecial xlPasteValues B = B + 2 Next End Sub

هل تريد مثلا : لصق تقرير بيانات1 ثم بعد اخر عمود لصق بيانات2 هل هكذا تريد بشرط نعلق فكرة اختيار عمود

السلام عليكم Private Sub ComboBox1_Change() If Me.ComboBox1.Value <> Empty Then Me.ComboBox2.Value = "OK" End Sub

السلام عليكم الاخ الفاضل nicola استفسار بسيط مالغايه من اختيار اعمدة اللصق ؟؟ اضن الاكتفاء بتحديد اي ورقة لعمل تقرير ليها يكفي اطرح الفكره كي نحاول نتوصل لحلول اخرى تفي بالغرض

بيكون كالتالي Private Sub Worksheet_Change(ByVal T As Excel.Range) Static S_Ali% If T.Row < 2 And T.Column <> 2 Then Exit Sub With T If Not Intersect(T, [B4:B200]) Is Nothing Then If Not IsEmpty(.Value) And IsNumeric(.Value) Then S_Ali = S_Ali + .Value Else: S_Ali = 0 End If Application.EnableEvents = False [P5] = S_Ali Application.EnableEvents = True End If End With End Sub

السلام عليكم بيكون هكذا Option Explicit Public Sub Ali() Dim X% Dim R As Range Dim Rt As Range X = Cells(Rows.Count, 1).End(xlUp).Row Set R = Union(Range("A2:A" & X), Range("C2:D" & X)) With Sheets("Sheet3") For Each Rt In R If Rt.Value = "م.باطن" Then Rt.Copy .Range("A" & Sheets("Sheet3").[A1000].End(xlUp).Row + 1) End If Next End With End Sub

السلام عليكم الاخ الفاضل goodlife فرضا الخليه المراد استخدامها " A2 " استخدم الكود التالي في حدث الورقة Private Sub Worksheet_Change(ByVal T As Excel.Range) On Error Resume Next Static S_Ali As Double With T If Not Intersect(.Value, [A2]) Is Nothing Then If Not IsEmpty(.Value) And IsNumeric(.Value) Then _ S_Ali = S_Ali + .Value Else: S_Ali = 0 Application.EnableEvents = False .Value = S_Ali Application.EnableEvents = True End If End With End Sub

السلام عليكم الاخ الفاضل abuhussein علامة + اذهب الى خيارات الاكسل ثم خيارات متقدمة وتأكد من ان خيار " تمكين مقبض التعبئة وسحب الخلية وإفلاتها " محفز

قبل الشرط يقوم بحذف البيانات الموجودة قبل الترحيل والورقة اذا لم تكن المعنيه غير الاسم من الكود الى اسم الورقة المراده Sheets("Sheet3")

ضيف هذا السطر في اول الكود مع تحديد المدى واسم الورقة الصحيح Sheets("Sheet3").[A2:A1000].ClearContents

السلام عليكم استخدم هذا الكود في حدث الورقة If Not Intersect(Target, [B2:B2000]) Is Nothing Then Application.ScreenUpdating = False I = 1: R = 2 Do While I < [B1500].End(xlUp).Row: Cells(R, 1).Value = I I = I + 1: R = R + 1 Loop Application.ScreenUpdating = True End If

السلام عليكم الاخ الفاضل نور جعفر جزيت خيرا وزوجت بكرا عمل ولااروع تمنياتي لك دوام الصحه والى مزيد من الإبداع تقبل مروري

السلام عليكم استخدم هذا الكود في حدث ورقة "قائمة فصل" Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, [F2]) Is Nothing Then Dim SH As Worksheet Dim R As Range Set SH = Sheets("البيانات") Range("A4:D5686").ClearContents SH.AutoFilterMode = False SH.Range("H3").CurrentRegion.AutoFilter Field:=8, Criteria1:=Target With SH.AutoFilter.Range Set R = .Offset(1, 1).Resize(.Rows.Count - 1, 2).SpecialCells(xlCellTypeVisible) If Not R Is Nothing Then R.Copy ActiveSheet.Range("B" & ActiveSheet.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Row) I = 1 RI = 4 Do While I < Range("B1500").End(xlUp).Row - 2 Cells(RI, 1).Value = I I = I + 1 RI = RI + 1 Loop End If End With SH.AutoFilterMode = False End If End Sub

زر الاستدعاء من الفورم الاخر بيكون هكذا Private Sub CommandButton1_Click() kh_Find1 End Sub