تعديل كود او استبداله بما افضل واسهل منه

[ابو حمادة]

السلام عليكم ورحمة الله وبركاته

ارجو من الاخوة الافاضل اصحاب الخبره اساتذتى الكرام

يوجد كود به بعض الاخطاء اريد تعديله او تغييره بما افضل واسهل منه ان امكن

وجزاكم الله عنا خيرا

مرفق ملف توضيح المطلوب

تعديل كود.rar

[سليم حاصبيا]

جرب هذا الملف

ليس بحاجة الى وضع اي كود في جدث الصفحة

Sub copy_data()
    With Sheets("sheet2")
        lr2 = .Cells(Rows.Count, 2).End(3).Row:   If lr2 < 8 Then lr2 = 8
        lr1 = Sheets("sheet1").Cells(Rows.Count, 2).End(3).Row: If lr1 < 8 Then lr1 = 8
          Sheets("sheet1").Range("b8:o" & lr1).ClearContents
          .Range("b8:o" & lr2).Copy Sheets("sheet1").Range("b8")
      End With
End Sub

 

 

تعديل كود Salim.rar

[ابو حمادة]

شكرا لاهتمامك  استاذي الغالي  سليم حاصبيا  

عند استخدا هذا الكود بيتم استدعاء كل البيانات لو امكن انا عايز الكود يستبعد اي صف به كلمة سحب او كلمة ايداع الموجوده في العمود ( D ) وللا يتم استدعاؤه من صفحة البيانات

ثانيا انا عايز اضافه دالة في الكود دالة للجمع في الاعمده الملونه في الملف المرفق

وجزاك الله خيرا

[سليم حاصبيا]

تم معالجة الامر بالنسبة للسؤال الاول

بالنسبة للسؤال الثاني اعتقد انه معادلة عادية يمكن ادراجها (()=Sum)

Sub copy_data()
m = 0
    With Sheets("sheet2")
            lr2 = .Cells(Rows.Count, 4).End(3).Row:   If lr2 < 8 Then lr2 = 8
            lr1 = Sheets("sheet1").Cells(Rows.Count, 2).End(3).Row: If lr1 < 8 Then lr1 = 8
              Sheets("sheet1").Range("b8:o" & lr1).ClearContents
    
              Set my_rg = Sheets("sheet2").Range("d8:d" & lr2). _
              SpecialCells(xlCellTypeConstants, 1).Offset(0, -2)
            For i = 1 To my_rg.Areas.Count
                my_rg.Areas(i).Resize(my_rg.Areas(i).Rows.Count, 14).Copy Sheets("sheet1").Cells(m + 8, 2)
                m = m + my_rg.Areas(i).Rows.Count
            Next
       End With
      
End Sub

 

تعديل كود Salim1.rar

[ابو حمادة]

شكرا ليك استاذ سليم حاصبيا علي مجهودك

وشكرا جدا لاهتمامك

انت والاستاذ ياسر خليل 

علي مساعدتكم ليا في هذا الطلب

الاستاذ  ياسر خليل وضع كود بصراحه جميل وكود اخر لجمع الصفوف المطلوبه 

جزاه الله خيرا

ولكن ليا تعديل لو امكن علي كود الجمع الذي  ساعدنى فيه الاستاذ ياسر 

مرفق ملف للتوضيح اكثر

تعديل.rar

Private Sub Worksheet_Change(ByVal Target As Range)
     Dim rng1        As Range
   ' Dim rng2        As Range
   ' Dim rng3        As Range
   ' Dim rng4        As Range
     Lr = Cells(Rows.Count, 1).End(xlUp).Row
     Set rng1 = Range("S8:S" & Lr)
   ' Set rng2 = Range("W8:W" & Lr)
   ' Set rng3 = Range("AA8:AA" & Lr)
   ' Set rng4 = Range("AC8:AC" & Lr)
    
     Application.ScreenUpdating = False
    ' ==============================================
' = اذا تم الكتابة في العمود 18 يتم تنفيذ هذا الجزء
With rng1
     If Target.Column <> 1 Or Target.Row < 1 Then Exit Sub
        .Formula = "=IF($A8="""","""",IF(R8=""Û"",""ÛÇÆÈ"",SUM(P8:R8)))"
        .Value = .Value
         End With
         
         
    ' ==============================================
' = اذا تم الكتابة في العمود 22 يتم تنفيذ هذا الجزء
'With rng2
'    If Target.Column <> 22 Or Target.Row < 22 Then Exit Sub
  '     .Formula = "=IF($A8="""","""",IF(V8=""Û"",""ÛÇÆÈ"",SUM(T8:V8)))"
'       .Value = .Value
'       End With


    ' ==============================================
' = اذا تم الكتابة في العمود 25 يتم تنفيذ هذا الجزء
'With rng3
'    If Target.Column <> 25 Or Target.Row < 25 Then Exit Sub
'       .Formula = "=IF($A8="""","""",IF(Z8=""Û"",""ÛÇÆÈ"",SUM(X8:Z8)))"
'       .Value = .Value
'       End With


    ' ==============================================
' = اذا تم الكتابة في العمود 27 يتم تنفيذ هذا الجزء
'With rng4
'    If Target.Column <> 27 Or Target.Row < 27 Then Exit Sub
'       .Formula = "=IF($A8="""","""",IF(AB8="""","""",AB8))"
'       .Value = .Value
'       End With

    ' ==============================================
     Application.ScreenUpdating = True
    MsgBox "Done...", 64

Exit Sub
End Sub

 

[ياسر خليل أبو البراء]

السلام عليكم

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

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Lr As Long

    Lr = Cells(Rows.Count, 1).End(xlUp).Row

    Application.ScreenUpdating = False
        If Target.Row > 7 And Target.Row <= Lr And Target.Column = 18 Then
            Target.Offset(, 1).Value = Application.WorksheetFunction.Sum(Target.Offset(, -2).Resize(1, 3))
        End If
        
        'يمكن بنفس الطريقة تطبيق الثلاثة أسطر السابقة على بقية النطاقات مع تغيير طفيف
    Application.ScreenUpdating = True
End Sub

 

[ابو حمادة]

2 ساعات مضت, ياسر خليل أبو البراء said:

السلام عليكم

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

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Lr As Long

    Lr = Cells(Rows.Count, 1).End(xlUp).Row

    Application.ScreenUpdating = False
        If Target.Row > 7 And Target.Row <= Lr And Target.Column = 18 Then
            Target.Offset(, 1).Value = Application.WorksheetFunction.Sum(Target.Offset(, -2).Resize(1, 3))
        End If
        
        'يمكن بنفس الطريقة تطبيق الثلاثة أسطر السابقة على بقية النطاقات مع تغيير طفيف
    Application.ScreenUpdating = True
End Sub

 

الله ينور عليك استاذ ياسر تسلم ايدك بس معلش محتاج شرط انه ميطبقش الجمع غير لو كان العمود ( A ) فيه بيانات لنفس الصف

الامر الثاني يريت توضع كمان نطاق من المحددين عشان اعرف وافهم ازى اضيف نطاقات مختلفه لاني هنا مش شايف اي معادله مقدرتش افهم او اضيف طفيف كما قلت 

ولو كان الافضل من وجهة نظرى يكون الكود نفس ال حضرتك كنت كاتبه وانسخ انا المعادله فيه بين علمتين تنصيص لكي اتمكن من تغييرها حسب المطلوب

وشكرا ليك علي اهتمامك ومجهودك الاكثر من رائع

 

 

 

تم تعديل أكتوبر 16, 2016 بواسطه ابو حمادة

[ياسر خليل أبو البراء]

بالنسبة للشرط المطلوب إضافته ..ممكن تكتب الشرط بالشكل ده

If target.Row > 7 And target.Row <= Lr And target.Column = 18 And Not IsEmpty(Range("A" & target.Row)) Then

 

[ابو حمادة]

والله ياستاذ ياسر خليل أبو البراءانا

مش عارف اشكرك ازى علي اهتممك وعلي مجهوداتك 

[ياسر خليل أبو البراء]

الحمد لله أن تم المطلوب على خير والحمد لله الذي بنعمته تتم الصالحات

قم بوضع الكود النهائي بعد أن قمت بالتعديلات ليستفيد منه الجميع

تقبل تحياتي