عبدالله باقشير

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم ' عدد الاعمدة Private Const Cont As Integer = 2 Sub kh_Find() Dim Ary() Dim i As Long, ii As Long, Lr As Long Dim dt1 As Double, dt2 As Double Dim txt As String Lr = Cells(Rows.Count, "H").End(xlUp).Row If Lr > 4 Then Range("H5:I" & Lr).ClearContents On Error GoTo 1 txt = [H3] dt1 = [I3] dt2 = [J3] With ورقة1 Lr = .Cells(.Rows.Count, "a").End(xlUp).Row For i = 2 To Lr Select Case .Cells(i, "B").Value2: Case dt1 To dt2 If InStr(CStr(.Cells(i, "A")), txt) Then ii = ii + 1 ReDim Preserve Ary(1 To Cont, 1 To ii) Ary(1, ii) = .Cells(i, "C").Value Ary(2, ii) = .Cells(i, "D").Value End If End Select Next End With If ii Then Range("H5").Resize(ii, Cont).Value = WorksheetFunction.Transpose(Ary) 1 Erase Ary End Sub المرفق 2010 بحث وسرد.rar

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

شاهد المرفق 2003 teste1.rar

يمكنك نسخ زر ظهور الفورم لكل ورقة وسيعمل الفورم للورقة النشطة المرفق 2003 teste1.rar

السلام عليكم ورحمة الله وبركاته جزاكم الله خيرا لم انتبه لعمل دالة التسلسل بعد الحذف وبامكانك استخدام المعادلة التالية =ROW()-1 تحياتي

شاهد المرفق 2003 ادراج صفوف لاسفل بنفس التنسيق والمعادلات دون التأثير على عملية الجمع+.rar

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

السلام عليكم اخي الحبيب عباس السماوي ...........حفظكم الله غير هذا الكود وسيتعامل مع معادلات الصفيف Sub kh_cFormula(MyRng As Range, iRow As Integer, Lastrow As Long) Dim Col As Range Dim R As Long '======================== For Each Col In MyRng.Cells If Col.HasFormula Then For R = iRow To Lastrow With MyRng.Worksheet If Col.HasArray Then .Cells(R, Col.Column).FormulaArray = Col.FormulaR1C1 Else .Cells(R, Col.Column).Formula = Col.FormulaR1C1 End If .Cells(R, Col.Column).Value = .Cells(R, Col.Column) End With Next R End If Next '======================== Set Col = Nothing End Sub تحياتي

السلام عليكم اخي الحبيب عباس السماوي ...........حفظكم الله غير هذا الكود وسيتعامل مع معادلات الصفيف Sub kh_cFormula(MyRng As Range, iRow As Integer, Lastrow As Long) Dim Col As Range Dim R As Long '======================== For Each Col In MyRng.Cells If Col.HasFormula Then For R = iRow To Lastrow With MyRng.Worksheet If Col.HasArray Then .Cells(R, Col.Column).FormulaArray = Col.FormulaR1C1 Else .Cells(R, Col.Column).Formula = Col.FormulaR1C1 End If .Cells(R, Col.Column).Value = .Cells(R, Col.Column) End With Next R End If Next '======================== Set Col = Nothing End Sub تحياتي

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم جرب هذا الكود Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim S As String If Intersect(Range("H7:H11"), Target) Is Nothing Then S = " " Else S = Range("G7:G11").Item(Target.Row - 6) End If ThisWorkbook.Names("kh_tst").RefersTo = S End Sub المرفق 2010 التنسيق.rar

السلام عليكم هذا مع نسخ المعادلات Private Const ContColumn As Integer = 6 Sub Kh_Insert_Rows() Dim MyRow As Integer MyRow = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & 1, Title:="ادراج عدد محدد من صفوف ", Default:=1, Type:=1) If MyRow = False Then Exit Sub With Cells(Rows.Count, "B").End(xlUp).Offset(-1, 0).Resize(MyRow, ContColumn) .Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove With .Offset(-(MyRow + 1), 0).Resize(1) .AutoFill Destination:=.Resize(MyRow + 1), Type:=xlFillDefault End With With .Offset(-MyRow, 0).Resize(MyRow) On Error Resume Next .SpecialCells(xlCellTypeConstants).ClearContents On Error GoTo 0 .Cells(1, 1).Select End With End With MsgBox "تم ادراج الصفوف المطلوبة بنجاح", 524288 + 1048576, "الحمدلله" End Sub تحياتي ادراج صفوف لاسفل بنفس التنسيق والمعادلات دون التأثير على عملية الجمع+.rar

السلام عليكم هذا مع اختيار عدد الصفوف المضافة Private Const ContColumn As Integer = 6 Sub Macro1() Dim MyRow As Integer MyRow = Application.InputBox(Prompt:=" ادخل عدد الصفوف " & Chr(10) & "عدد الصفوف الافتراضية " & 1, Title:="ادراج عدد محدد من صفوف ", Default:=1, Type:=1) If MyRow = False Then Exit Sub With Cells(Rows.Count, "B").End(xlUp).Offset(-1, 0).Resize(MyRow, ContColumn) .Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove .Offset(-MyRow, 0).Resize(MyRow).Borders.LineStyle = 1 End With End Sub شاهد المرفق 2003 ادراج صفوف لاسفل بنفس التنسيق والمعادلات دون التأثير على عملية الجمع+.rar

السلام عليكم جرب هذا (لازم يكون صف فاضي بين صفوف الجدول وصف الاجمالي) Private Const ContColumn As Integer = 6 Sub Macro1() With Cells(Rows.Count, "B").End(xlUp).Offset(-1, 0).Resize(1, ContColumn) .Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove .Offset(-1, 0).Borders.LineStyle = 1 End With End Sub تحياتي

هذه محاولة بدون استخدام صفيف TestData(3)-00.rar

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم جزاكم الله خيرا تقبلوا تحياتي وشكري

السلام عليكم جرب المعادلة التالية =SUBSTITUTE(SUBSTITUTE(A2;"-";"");" ";"") تحياتي

السلام عليكم جزاكم الله خيرا ==================== ضع المعادلة في b1 واسحبها على باقي الاعمدة =MID($A1;COLUMN(A1);1)

السلام عليكم تعديل طفيف على ملف اختي الفاضلة ام عبدالله ...حفظها الله تجزئة التاريخ ‫‬.rar

السلام عليكم جرب التالي: ActiveCell = Application.WorksheetFunction.Index(ورقة2.[A1:A13], _ Application.WorksheetFunction.Match(Cells(tt, "H"), ورقة2.[B1:B13], 0), 0)