سليم حاصبيا

زيادة في اثراء الموضوع هذا الكود Option Explicit Sub copy_as_you_want() Dim i, c As Integer Dim Cont Dim Lr As Long Lr = ActiveSheet.Cells(Rows.count, 3).End(3).Row Range("c3:c" & Lr).ClearContents i = 3 c = 3 Do While Cells(i, 1) <> "" Cont = Cells(i, 1).Offset(0, 1).Value If Not IsNumeric(Cont) Or Cont = "" Or Cont = 0 Then i = i + 1: GoTo 1 Cont = Int(Abs(Cont)) Range("c" & c & ":c" & c + Cont - 1).Value = Cells(i, 1).Value i = i + 1 c = c + Cont 1: Loop End Sub

ربما يكون المطلوب نسخ خلايا Salim.rar

جرب ان تكتب اي معادلة في العامود الثالث عند الضغط على Enter سوف تجد ان محتويات الخلية هي غبارة عن قيمة ما أنتجته المعادلة و ليس معادلة بحد ذاتها نستطيع ان تعرف ذلك باعادة تحديد الخلية (لا تظهر لك المعادلة)

اذا كنت ما فهمته صحيحاً جرب هذا الملف كنموذج (الكود ينفذ على العمود الثالث فقط) للتجربة Formula_value.rar

الكود يقوم يحساب الواصل والمتبقى و ما عليك الا ان تضع ارقاماً في الصفحة الرئيسية بالنسبة لحجم الخط اضف هذا السطر Cells.Font.Size = 16: .Cells.Font.Bold = True. الى الكود Give_data وذلك بعد هذا السطر .Range("c5:o" & lrk + 1).Borders.LineStyle = xlContinuous ليصبح الكود Give_data بهذا الشكل Sub Give_data() Dim lr, lrk As Integer Dim k As Integer Dim Nam As String Dim my_sh As Worksheet Dim c As Integer lr = Main.Cells(Rows.Count, 2).End(3).Row For k = 2 To Sheets.Count c = 5 Nam = Sheets(k).Name Set my_sh = Sheets(k) my_sh.Range("b5:o500").ClearContents my_sh.Range("b5:o500").ClearFormats For i = 5 To lr If Main.Range("b" & i) = Nam Then my_sh.Range("c" & c).Resize(1, 13).Value = Main.Range("c" & i).Resize(1, 13).Value c = c + 1 End If Next lrk = Sheets(k).Cells(Rows.Count, 3).End(3).Row With Sheets(k) .Columns("F:H").EntireColumn.Hidden = True .Range("b" & lrk + 1) = "المجاميع" .Range("f" & lrk + 1).Formula = "=SUM(f5:f" & lrk & ")" .Range("g" & lrk + 1).Formula = "=SUM(g5:g" & lrk & ")" .Range("h" & lrk + 1).Formula = "=SUM(h5:h" & lrk & ")" .Range("i" & lrk + 1).Formula = "=SUM(i5:i" & lrk & ")" .Range("k" & lrk + 1).Formula = "=SUM(k5:k" & lrk & ")" .Range("l" & lrk + 1).Formula = "=SUM(l5:l" & lrk & ")" .Range("m" & lrk + 1).Formula = "=SUM(m5:m" & lrk & ")" .Range("c" & lrk + 1 & ":o" & lrk + 1).Value = .Range("c" & lrk + 1 & ":o" & lrk + 1).Value .Range("b" & lrk + 1 & ":o" & lrk + 1).Interior.ColorIndex = 6 .Range("c5:o" & lrk + 1).Borders.LineStyle = xlContinuous .Cells.Font.Size = 16: .Cells.Font.Bold = True End With Next End Sub

تم التعديل على الكود كما تريد حسابات 3 salim.rar

بعد اذن الاخ خالد جرب هذا الملف حسابات 2 salim.rar

قم بوضع ملف صغير تعرض فيه النتيجة المتوقعة قبل الكود و بعده

جرب هذا الشيء محاوله salim.rar

كيف تجعل القائمة المنسدلة تحدد لك القسم الذي تريده من الجدول مع عدة خيارات : 1- من البداية حتى اسم معين في الجدول 2-من اسم معين حتى نهاية الجدول 3- بين اسمين في الجدول عسى ان ينال الاعجاب special_data_validation.rar

اسنبدل الكود بهذا Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 1 Or Target.Row <= 2 Then GoTo 1 lr = Cells(Rows.Count, 1).End(xlUp).Row + 1 Application.ScreenUpdating = False Range("A2:b" & lr).Sort Key1:=Range("A2"), Order1:=1, Header:=1 1: Application.ScreenUpdating = True End Sub عذراً اخي زيزو لم انتبه لمشاركتك الا بعد ادراج مشاركتي

شاهد هذا الفيديو https://www.youtube.com/watch?v=r6KjcihBpoY

شرح الكود Explain.rar

بالنسبة لادراج المعادلة داخل كود شاهد هذا الفيديو https://www.youtube.com/watch?v=DCXWHS-BL2w

اذا كنت تريد ان يعمل على كل صف يمفرده (كي يعمل الكود يجب ان لا تكون الخلية C في نقس الصف فارغة) اليك هذا الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Intersect(Target, Range("b:b")) Is Nothing Or Target.Row < 6 Then GoTo 1 If Target.Offset(0, 1) = "" Then GoTo 1 Dim My_Row As Long Dim m_B As Range My_Row = Target.Row Set m_B = Target.Offset(0, 2).Resize(1, 2) m_B.Formula = "=IF($B" & My_Row & "="""","""" ,ROUND($C" & My_Row & "*d$4,2))" m_B.Value = m_B.Value 1: Application.EnableEvents = True Set m_B = Nothing End Sub

جرب هذا الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Dim My_Row As Long Dim m_B, My_range As Range My_Row = Range("b:B").Find("", after:=Range("b5")).Row - 1 Set m_B = Range("b6:b" & My_Row) Set My_range = Range("d6:e" & My_Row) If Intersect(Target, m_B) Is Nothing Then GoTo 1 My_range.Formula = "=IF($B6="""","""",ROUND($C6*d$4,2))" My_range.Value = My_range.Value 1: Application.EnableEvents = True Set m_B = Nothing: Set My_range = Nothing End Sub

اليك هذا الماكرو Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$O$2" Then If Target <> "" Then Range("i2") = Format(Now, "d/m/yyyy >>>hh:mm:ss") _ Else Range("i2") = "" End If Application.EnableEvents = True End Sub

بعد اذن اخي بن علية.... هذا الملف عسى ان ينال الاعجاب Gardens_Salim.rar

جرب هذا الماكرو Option Explicit Sub Give_Data() Dim k, x, t As Integer Dim sh1, sh2 As Worksheet Dim my_rg As Range Set sh1 = Sheets("بيانات") Set sh2 = Sheets("Sheet1") k = sh1.Cells(2, Columns.Count).End(xlToLeft).Column For x = 2 To k Step 8 If my_rg Is Nothing Then Set my_rg = sh1.Cells(2, x).Resize(4, 1) Else Set my_rg = Union(my_rg, sh1.Cells(2, x).Resize(4, 1)) End If Next t = sh2.Range("b2").Value If Not IsNumeric(t) Or t <= 0 Then MsgBox "Choose correct Number in $B$2...Please": Exit Sub If t > my_rg.Areas.Count Then t = my_rg.Areas.Count With my_rg.Areas(t) sh2.Cells(4, 2) = .Cells(1) sh2.Cells(4, 6) = .Cells(1).Offset(0, 4) sh2.Cells(5, 2) = .Cells(2) sh2.Cells(5, 6) = .Cells(2).Offset(0, 4) sh2.Cells(6, 2) = .Cells(3) sh2.Cells(7, 2) = .Cells(4) End With End Sub مرفق الملف example1 salim.rar

حيث انك لم ترفع ملف للتطبيق اليك هذا النموذج somme au choix.rar

تفضل الملف جاهز و زيادة حبتين تسلسل Salim.rar

جرب هذه المعادلة (Ctrl+Shift+Enter) =MAX(IF(ISNA(MATCH(ROW($A$1:$A$10),$A$1:$A$10,0)),ROW($A$1:$A$10)))

بعد اذن اخي خالد انظر الى هذا الملف ريما يكون المطلوب تم حمابة المعادلات لعدم العبث بها عن طريق الخطأ wsh_Salim.rar

هنا يحذرك اكسل ان الملف الجديد (2003) لا تنطبق علية كل مميزات 2007 و هذا شيء طبيعي اضغط على متابعة لان الملف الاصلي 2007 لا يتأثر بذلك

بعد فتح الملف عندك على 2007 قم بما يلي 1-اضغط F12 تظهر لك نافذة 2-اختر من هذه النافذة Save as Type وانقر على السهم الصغير بجانبها 3-من القائمة التي تظهر اختر Excel 97-2003 workbook 4-اعط اسماً اخر للملف من file name مثلاً (Book1_2003) 5- هكذا يصبح لديك نفس الملف باسم اخر يعمل على 2003 و يمكنك اعطاؤة لصديقك