معادلة أو كود لكتابة تاريخ اليوم وترحيل هذا التاريخ الى شيت اخر استنادا الى رقم الادخال

[نبا زيد]

السلام عليكم

محتاج معادلة أو كود

لترحيل تاريخ من شيت الى شيت اخر عند الضغط على طباعة الورقة

معادلة الرقم كتابة + ترحيل رقم الادخال الى شيت اخر استنادا لرقم الادخال.xlsx

[محمد هشام.]

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

جرب هل هدا ما تقصده 

Option Explicit
Sub TransferDate()
    Dim tmp As Double, n As Long
    Dim WS As Worksheet, dest As Worksheet
    
    Set WS = Sheets("الادخال")
    Set dest = Sheets("البيانات")
    
    tmp = WS.Range("C5").Value
    
    If IsNumeric(tmp) And tmp <> 0 Then
        n = dest.Cells(dest.Rows.Count, 1).End(xlUp).Row + 1
        
        dest.Cells(n, 1).Value = tmp
        dest.Cells(n, 20).Value = Date
    End If
End Sub

للترحيل الى نفس الخلايا بشكل دائم 

Sub TransferDateFix()
    Dim tmp As Double
    Dim WS As Worksheet, dest As Worksheet
    Set WS = Sheets("الادخال")
    Set dest = Sheets("البيانات")
    
    tmp = WS.Range("C5").Value
    
    If IsNumeric(tmp) And tmp <> 0 Then
        dest.Range("A2").Value = tmp
        dest.Range("T2").Value = Date
    End If
End Sub

 

معادلة الرقم كتابة + ترحيل رقم الادخال الى شيت اخر استنادا لرقم الادخال.xlsb

[نبا زيد]

السلام عليكم

اشكرك على سرعة الرد (ممنون)

ولكن

اني محتاج ارحل تاريخ الادخال فقط الى شيت البيانات تلقائيا عند الضغط على انتر او عند القيام بالطابعة (اي الكود في ورقة الحدث)

لان رقم الادخال هو بالاساس موجود في شيت البيانات

والترحيل تاريخ الادخال على اساس رقم الادخال 

1.xlsm

تم تعديل نوفمبر 8 بواسطه صباح2024

[محمد هشام.]

إذا تم إدخال قيمة رقمية في  الخلية C5 يقوم الكود  بالبحث عن نفس الرقم في العمود الأول (A) في ورقة البيانات  و تحديث التاريخ في العمود  (T)  يمكنك تعديله بما يناسبك  

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim WS As Worksheet, dest As Worksheet
    Dim tmp As Double, n As Long,cell As Range
    
    Set WS = ThisWorkbook.Sheets("الادخال")
    Set dest = ThisWorkbook.Sheets("البيانات")
    
    If Not Intersect(Target, WS.Range("C5")) Is Nothing Then
        tmp = WS.Range("C5").Value
        
        If IsNumeric(tmp) And tmp <> 0 Then
            On Error Resume Next
            Set cell = dest.Range("A2:A" & _
            dest.Rows.Count).Find(tmp, LookIn:=xlValues, LookAt:=xlWhole)
            On Error GoTo 0
            
            If Not cell Is Nothing Then
                cell.Offset(0, 19).Value = Date
            End If
        End If
    End If
End Sub

 

1.xlsm

[نبا زيد]

تمام - تسلم

جزيت خيرا

100 %

فقط ملاحظة : ممكن لا يرحل التاريخ إلا بعد ان اكتبه واضغط انتر يرحل

 

 

تم تعديل نوفمبر 9 بواسطه صباح2024

[محمد هشام.]

9 ساعات مضت, صباح2024 said:

فقط ملاحظة : ممكن لا يرحل التاريخ إلا بعد ان اكتبه واضغط انتر يرحل

لا أعلم ما تحاول فعله لاكن جرب وضع  الكود التالي في Module

Public Sub RunCode()
    Dim WS As Worksheet, dest As Worksheet
    Dim tmp As Double, cell As Range

    Set WS = ThisWorkbook.Sheets("الادخال")
    Set dest = ThisWorkbook.Sheets("البيانات")
    tmp = WS.Range("C5").Value
    If IsNumeric(tmp) And tmp <> 0 Then
        On Error Resume Next
        Set cell = dest.Range("A2:A" & _
        dest.Rows.Count).Find(tmp, LookIn:=xlValues, LookAt:=xlWhole)
        On Error GoTo 0

        If Not cell Is Nothing Then
            cell.Offset(0, 19).Value = Date
        End If
    End If
End Sub

 وفي حدث ThisWorkbook 

Private Sub Workbook_Open()
    Application.OnKey "{F10}", "RunCode"
End Sub
'====================
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.OnKey "{F10}"
End Sub

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

2.xlsm

[نبا زيد]

جزاك الله خير

تسلم