طلب مساعدة منع التكرار في كود

[أبو عبدالإله]

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

 

هذا كود للأستاذ المبدع ياسر كنت قد طلبته سابقا 

 

هل يمكن التعديل عليه لكي يمنع التكرار في حالة الضغط عليه مرة أخرى 

بمعنى عند الضغط عليه يقوم بجلب البيانات ، وعندما تضغط عليه مرة أخرى يجلب البيانات ويضعها مع البيانات السابقة 

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

 

 

Sub Test()
    Dim WS As Worksheet, SH As Worksheet
    Dim Cel As Range
    Dim lRow As Long
    Set WS = Sheets("أداة بناء الخطط"): Set SH = Sheets("ورقة1")
    
    Application.ScreenUpdating = False
        For Each Cel In WS.Range("H3:H43")
            If Cel.Value >= 0.9 Then
                lRow = SH.Cells(Rows.Count, "B").End(xlUp).Row + 1
                SH.Cells(lRow, "B").Value = Cel.Offset(, 1)
            ElseIf Cel.Value <= 0.5 Then
                lRow = SH.Cells(Rows.Count, "H").End(xlUp).Row + 1
                SH.Cells(lRow, "H").Value = Cel.Offset(, 1)
            End If
        Next Cel
    Application.ScreenUpdating = True
End Sub

 

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

أخي العزيز أبو عبد الإله

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

قم بإرفاق ملفك لتتضح صورة طلبك ليساهم الجميع في تقديم المساعدة

[أبو عبدالإله]

شاكر ومقدر لك أستاذي ياسر

 

وهذا هو الملف

 

نموذح.rar

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

جرب الكود بهذا الشكل

Sub Test()
    Dim WS As Worksheet, SH As Worksheet
    Dim Cel As Range
    Dim lRow As Long
    Set WS = Sheets("أداة بناء الخطط"): Set SH = Sheets("ورقة1")
    
    Application.ScreenUpdating = False
    
        SH.Range("B3:M1000").ClearContents
        
        For Each Cel In WS.Range("H3:H43")
            If Cel.Value >= 0.9 Then
                lRow = SH.Cells(Rows.Count, "B").End(xlUp).Row + 1
                SH.Cells(lRow, "B").Value = Cel.Offset(, 1)
            ElseIf Cel.Value <= 0.5 Then
                lRow = SH.Cells(Rows.Count, "H").End(xlUp).Row + 1
                SH.Cells(lRow, "H").Value = Cel.Offset(, 1)
            End If
        Next Cel
    Application.ScreenUpdating = True
End Sub

تم إضافة سطر واحد يقوم بمسح البيانات قبل الشروع في الكود

SH.Range("B3:M1000").ClearContents

تقبل تحياتي

 

[أبو عبدالإله]

حرم الله وجهك عن النار ورزقك من غير حساب

 

بذل وعطاء ليس مستغرب عن شخصكم الكريم

 

كل الدعوات القلبية لكم أستاذنا الفاضل

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

بارك الله فيك أخي الفاضل أبو عبد الإله وجزيت خيراً على دعواتك الطيبة .. رغم أنني لم أقدم في الموضوع سوى سطر بسيط جداً ..

الأخ الغالي أحمد مشكور على الإعجاب وعلى المتابعة المستمرة للمنتدى

 

الحمد لله الذي بنعمته تتم الصالحات

تقبلوا وافر تقديري واحترامي