كيفية تذكر أو حفظ القيمة السابقة لخلية تم تغييرها في Excel؟
عادةً، عند تحديث خلية بمحتوى جديد، يتم استبدال القيمة السابقة ما لم تقم بالتراجع عن العملية في Excel. ومع ذلك، إذا كنت ترغب في الاحتفاظ بالقيمة السابقة للمقارنة مع القيمة المحدثة، فإن حفظ القيمة السابقة للخلية في خلية أخرى أو في تعليق الخلية سيكون خيارًا جيدًا. ستساعدك الطريقة الموجودة في هذه المقالة على تحقيق ذلك.
حفظ القيمة السابقة للخلية باستخدام كود VBA في Excel
حفظ القيمة السابقة للخلية باستخدام كود VBA في Excel
لنفترض أن لديك جدول كما هو موضح في لقطة الشاشة أدناه. إذا تغيرت أي خلية في العمود C، قد ترغب في حفظ قيمتها السابقة في الخلية المقابلة من العمود G أو كتعليق تلقائي. يرجى اتباع الخطوات التالية لتحقيق ذلك.
1. في ورقة العمل التي تحتوي على القيم التي تريد حفظها عند التحديث، انقر بزر الماوس الأيمن على تبويب الورقة وحدد "عرض الكود" من قائمة النقر بزر الماوس الأيمن. انظر لقطة الشاشة:
2. في نافذة "Microsoft Visual Basic for Applications" التي ستظهر، قم بنسخ الكود التالي لـ VBA إلى نافذة الكود.
يساعدك الكود التالي لـ VBA في حفظ القيمة السابقة للخلية في عمود محدد إلى عمود آخر.
كود VBA: حفظ القيمة السابقة للخلية في خلية عمود آخر
Dim xRg As Range
Dim xChangeRg As Range
Dim xDependRg As Range
Dim xDic As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim xCell As Range
Dim xDCell As Range
Dim xHeader As String
Dim xCommText As String
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
xHeader = "Previous value :"
x = xDic.Keys
For I = 0 To UBound(xDic.Keys)
Set xCell = Range(xDic.Keys(I))
Set xDCell = Cells(xCell.Row, 7)
xDCell.Value = ""
xDCell.Value = xDic.Items(I)
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim I, J As Long
Dim xRgArea As Range
On Error GoTo Label1
If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
Set xDependRg = Target.Dependents
If xDependRg Is Nothing Then GoTo Label1
If Not xDependRg Is Nothing Then
Set xDependRg = Intersect(xDependRg, Range("C:C"))
End If
Label1:
Set xRg = Intersect(Target, Range("C:C"))
If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = Union(xRg, xDependRg)
ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = xDependRg
ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then
Set xChangeRg = xRg
Else
Application.EnableEvents = True
Exit Sub
End If
xDic.RemoveAll
For I = 1 To xChangeRg.Areas.Count
Set xRgArea = xChangeRg.Areas(I)
For J = 1 To xRgArea.Count
xDic.Add xRgArea(J).Address, xRgArea(J).Formula
Next
Next
Set xChangeRg = Nothing
Set xRg = Nothing
Set xDependRg = Nothing
Application.EnableEvents = True
End Sub
لحفظ القيمة السابقة للخلية في تعليق، يرجى تطبيق الكود التالي لـ VBA.
كود VBA: حفظ القيمة السابقة للخلية في التعليق
Dim xRg As Range
Dim xChangeRg As Range
Dim xDependRg As Range
Dim xDic As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim xCell As Range
Dim xHeader As String
Dim xCommText As String
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
xHeader = "Previous value :"
For I = 0 To UBound(xDic.Keys)
Set xCell = Range(xDic.Keys(I))
If Not xCell.Comment Is Nothing Then xCell.Comment.Delete
With xCell
.AddComment
.Comment.Visible = False
.Comment.Text xHeader & vbCrLf & xDic.Items(I)
End With
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim I, J As Long
Dim xRgArea As Range
On Error GoTo Label1
If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
Set xDependRg = Target.Dependents
If xDependRg Is Nothing Then GoTo Label1
If Not xDependRg Is Nothing Then
Set xDependRg = Intersect(xDependRg, Range("C:C"))
End If
Label1:
Set xRg = Intersect(Target, Range("C:C"))
If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = Union(xRg, xDependRg)
ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = xDependRg
ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then
Set xChangeRg = xRg
Else
Application.EnableEvents = True
Exit Sub
End If
xDic.RemoveAll
For I = 1 To xChangeRg.Areas.Count
Set xRgArea = xChangeRg.Areas(I)
For J = 1 To xRgArea.Count
xDic.Add xRgArea(J).Address, xRgArea(J).Text
Next
Next
Set xChangeRg = Nothing
Set xRg = Nothing
Set xDependRg = Nothing
Application.EnableEvents = True
End Sub
ملاحظة: في الكود، الرقم 7 يشير إلى العمود G الذي ستحفظ فيه القيمة السابقة، وC:C هو العمود الذي سيتم فيه إجراء التغيير. يرجى تغييرهما بناءً على احتياجاتك.
3. انقر على "أدوات" > "المراجع" لفتح مربع الحوار "المراجع – VBAProject"، ثم قم بتحديد مربع "Microsoft Scripting Runtime" وأخيرًا انقر على زر "موافق". انظر لقطة الشاشة:
4. اضغط على مفتاحي "Alt" + "Q" لإغلاق نافذة "Microsoft Visual Basic for Applications".
من الآن فصاعدًا، عند تحديث قيمة خلية في العمود C، سيتم حفظ القيمة السابقة في الخلية المقابلة في العمود G أو كتعليق، كما هو موضح في لقطات الشاشة أدناه.
حفظ القيم السابقة للخلايا في خلايا أخرى:
حفظ القيم السابقة للخلايا في التعليقات:
أفضل أدوات الإنتاجية لمكتب العمل
عزز مهاراتك في Excel مع Kutools لـ Excel، واختبر الكفاءة كما لم يحدث من قبل. Kutools لـ Excel يقدم أكثر من300 ميزة متقدمة لزيادة الإنتاجية وتوفير وقت الحفظ. انقر هنا للحصول على الميزة التي تحتاجها أكثر...
Office Tab يقدم واجهة التبويب لـ Office، ويجعل عملك أسهل بكثير
- تمكين تحرير وقراءة المستندات عبر التبويبات في Word وExcel وPowerPoint.
- افتح وأنشئ عدة مستندات في تبويبات جديدة ضمن نفس النافذة، بدلاً من فتحها في نوافذ منفصلة.
- يزيد إنتاجيتك بنسبة50%، ويقلل مئات النقرات بالماوس يومياً!