مساعدة في كود منع اللصق إلا كقيم

[خالد القدس2]

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

 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim areas As Range
    Dim cell As Range

    ' إعداد النطاقات المتعددة
    Set areas = Union(Me.Range("C10:L109"), Me.Range("S10:S109"), Me.Range("V10:V109"))

    ' التعامل مع تغيير الخلايا
    On Error GoTo ClearApp
    Application.EnableEvents = False

    ' منع اللصق إلا كقيم
    Set rng = Intersect(Target, areas)
    If Not rng Is Nothing Then
        For Each cell In rng
            If cell.HasFormula Then
                cell.Value = cell.Value ' تحويل القيمة إلى قيمة ثابتة
            End If
        Next cell
    End If


ExitHandler:
    Application.EnableEvents = True
    Exit Sub

ClearApp:
    Resume ExitHandler
End Sub

 

لصق كقيم فقط.xlsm

[mahmoud nasr alhasany]

جرب هذا الكود  

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim areas As Range
    Dim cell As Range

    ' إعداد النطاقات المتعددة
    Set areas = Union(Me.Range("C10:L109"), Me.Range("S10:S109"), Me.Range("V10:V109"))

    ' التعامل مع تغيير الخلايا
    On Error GoTo ClearApp
    Application.EnableEvents = False

    ' منع اللصق إلا كقيم
    Set rng = Intersect(Target, areas)
    If Not rng Is Nothing Then
        Application.Undo ' التراجع عن اللصق الأصلي
        For Each cell In rng
            cell.Value = Target.Value ' لصق القيمة فقط
        Next cell
    End If

ExitHandler:
    Application.EnableEvents = True
    Exit Sub

ClearApp:
    Resume ExitHandler
End Sub

 

[mahmoud nasr alhasany]

وهذا كود معدل لجعل النطاقات في areas تعتمد على LastRow لتكون ديناميكية وتتغير تلقائيًا مع عدد الصفوف في ورقة العمل

 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim areas As Range
    Dim lastRow As Long

    ' تحديد آخر صف يحتوي على بيانات في العمود C (أو أي عمود آخر يحتوي على بيانات)
    lastRow = Me.Cells(Me.Rows.Count, "C").End(xlUp).Row

    ' إعداد النطاقات المتعددة باستخدام LastRow
    Set areas = Union(Me.Range("C10:L" & lastRow), Me.Range("S10:S" & lastRow), Me.Range("V10:V" & lastRow))

    ' التعامل مع تغيير الخلايا
    On Error GoTo ClearApp
    Application.EnableEvents = False

    ' منع اللصق إلا كقيم
    Set rng = Intersect(Target, areas)
    If Not rng Is Nothing Then
        Application.Undo ' التراجع عن اللصق الأصلي
        For Each cell In rng
            cell.Value = Target.Value ' لصق القيمة فقط
        Next cell
    End If

ExitHandler:
    Application.EnableEvents = True
    Exit Sub

ClearApp:
    Resume ExitHandler
End Sub

 

[خالد القدس2]

السلام عليكم 
أستاذي الفاضل محمود   
الكود يعمل بشكل جيد ولكنه يمنع حتى الادخال اليدوي  
ولكن تم حل المسألة بطريقة أخرى  منع اللصق نهائيا  ثم استخدام كود آخر بزر للصق المنسوخ كقيم 

ألف شكر على محاولتك المساعدة  وجزيت خيرا