اشتباه در درج تاریخ سلول پر شده تحت شرایط خاص

[sabertb]

سلام به اساتید گرامی

چند وقت پیش با راهنمایی اساتید ماژولی نوشتم که تاریخ شمسی رو در سلول های متناظر سلول هایی که در آن اطلاعات ثبت میگردید به صورت خود کار وارد کند

ولی جدیدا متوجه یک اشکال اساسی در این ماژول شدم . زمانی که بالا یا پایین سلول خالی ای که قصد وارد کردن اطلاعات را داریم قبلا پر شده باشد (حاوی اطلاعات باشد) و بخاهیم سلول خالی این بین را پر کنیم متوجه شدم در سلول های متناظر و هم چنین سلول های بالایی و پایینی قسمت درج تاریخ . همه با هم به تاریخ روز تغییر میکنند ! در صورتی که من فقط میخواهم سلول متناظر همان سلول خالی به صورت خودکار تاریخ بگیره .
این جوری تاریخ های ثبت شده قبلی خودکار تغییر میکنه ! و به روز میشه . برای رفع این مشکل چه باید کرد ؟

در نمونه فایل ضمیمه شده. در قسمت تاریخ های خودکار (که با کاندیشن سبز مشخص شده) من بیشتر سلول هارا با عدد 11 پر کردم و فقط 2 ردیف 9 و 14 صفحه خالی است . وفتی شما در ستون های Process 1 تا Process 11 و ردیف 9 و 14 اطلاعاتی وارد میکنید به غیر از سلول های متناظرش در قسمت تاریخ سلول های بالا یا پایینی آن ها هم تغییر میکند.

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.

[iranweld]

با سلام

ظاهرا برای اجرای ماکرو در صورت تغییر در ستون r دو ماکرو متفاوت تعریف کردید

خط پایین را غیر فعال کنید درست جواب میده

[Amir Ghasemiyan]

سلام دوست عزیز
علاوه بر نکته ای که جناب iranweld مطرح کردند دقت کنید که وقتی عددی داخل محدوده وارد میکنید و اینتر رو میزنید target شما عوض میشه و سلول پایینی انتخاب میشه
یا باید از کلیدهای ترکیبی ctrl+enter استفاده کنید یا اینکه کدتون رو اصلاح کنید که سلول بالایی target رو لحاظ کنه

[sabertb]

با سلام

ظاهرا برای اجرای ماکرو در صورت تغییر در ستون r دو ماکرو متفاوت تعریف کردید

خط پایین را غیر فعال کنید درست جواب میده

این رنج ها تکراری ولی با اسامی جدید تعریف کردم تا بتونم با وارد کردن اطلاعات در سلول و رفتن به سلول پایین هم تاریخ رو ثبت کنه . در غیر این صورت وقتی شما اون دامنه ها و ماژول هارو نداشته باشید
برای

Sub data17()

Dim i, J As Integer
Dim rowNumberValue As Integer, columnNumberValue As Integer

 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column

If Cells(rowNumberValue - 1, 7) <> "" Then
  Cells(rowNumberValue - 1, 30) = J_TODAY(1)
    End If

End Sub
Sub data18()

Dim i, J As Integer

Dim rowNumberValue As Integer, columnNumberValue As Integer



 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column


If Cells(rowNumberValue - 1, 8) <> "" Then
  Cells(rowNumberValue - 1, 31) = J_TODAY(1)
      
End If

End Sub

Sub data19()

Dim i, J As Integer
Dim rowNumberValue As Integer, columnNumberValue As Integer

 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column

If Cells(rowNumberValue - 1, 9) <> "" Then
  Cells(rowNumberValue - 1, 32) = J_TODAY(1)
    End If

End Sub
Sub data20()

Dim i, J As Integer

Dim rowNumberValue As Integer, columnNumberValue As Integer



 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column


If Cells(rowNumberValue - 1, 10) <> "" Then
  Cells(rowNumberValue - 1, 33) = J_TODAY(1)
   
End If

End Sub

Sub data21()

Dim i, J As Integer
Dim rowNumberValue As Integer, columnNumberValue As Integer

 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column

If Cells(rowNumberValue - 1, 11) <> "" Then
  Cells(rowNumberValue - 1, 34) = J_TODAY(1)
    End If

End Sub
Sub data22()

Dim i, J As Integer

Dim rowNumberValue As Integer, columnNumberValue As Integer



 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column


If Cells(rowNumberValue - 1, 12) <> "" Then
  Cells(rowNumberValue - 1, 35) = J_TODAY(1)
      
End If

End Sub

Sub data23()

Dim i, J As Integer
Dim rowNumberValue As Integer, columnNumberValue As Integer

 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column

If Cells(rowNumberValue - 1, 13) <> "" Then
  Cells(rowNumberValue - 1, 36) = J_TODAY(1)
    End If

End Sub
Sub data24()

Dim i, J As Integer

Dim rowNumberValue As Integer, columnNumberValue As Integer



 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column


If Cells(rowNumberValue - 1, 14) <> "" Then
  Cells(rowNumberValue - 1, 37) = J_TODAY(1)
   
End If

End Sub

Sub data25()

Dim i, J As Integer
Dim rowNumberValue As Integer, columnNumberValue As Integer

 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column

If Cells(rowNumberValue - 1, 15) <> "" Then
  Cells(rowNumberValue - 1, 38) = J_TODAY(1)
    End If

End Sub
Sub data26()

Dim i, J As Integer

Dim rowNumberValue As Integer, columnNumberValue As Integer



 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column


If Cells(rowNumberValue - 1, 16) <> "" Then
  Cells(rowNumberValue - 1, 39) = J_TODAY(1)
      
End If

End Sub

Sub data27()

Dim i, J As Integer
Dim rowNumberValue As Integer, columnNumberValue As Integer

 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column

If Cells(rowNumberValue - 1, 17) <> "" Then
  Cells(rowNumberValue - 1, 40) = J_TODAY(1)
    End If

End Sub
Sub data28()

Dim i, J As Integer

Dim rowNumberValue As Integer, columnNumberValue As Integer



 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column


If Cells(rowNumberValue - 1, 18) <> "" Then
  Cells(rowNumberValue - 1, 41) = J_TODAY(1)
   
End If

End Sub

Sub data29()

Dim i, J As Integer
Dim rowNumberValue As Integer, columnNumberValue As Integer

 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column

If Cells(rowNumberValue - 1, 19) <> "" Then
  Cells(rowNumberValue - 1, 42) = J_TODAY(1)
    End If

End Sub
Sub data30()

Dim i, J As Integer

Dim rowNumberValue As Integer, columnNumberValue As Integer



 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column


If Cells(rowNumberValue - 1, 20) <> "" Then
  Cells(rowNumberValue - 1, 43) = J_TODAY(1)
      
End If

End Sub

Sub data31()

Dim i, J As Integer
Dim rowNumberValue As Integer, columnNumberValue As Integer

 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column

If Cells(rowNumberValue - 1, 21) <> "" Then
  Cells(rowNumberValue - 1, 44) = J_TODAY(1)
    End If

End Sub

Sub data32()

Dim i, J As Integer
Dim rowNumberValue As Integer, columnNumberValue As Integer

 rowNumberValue = ActiveCell.Row
columnNumberValue = ActiveCell.Column

If Cells(rowNumberValue - 1, 22) <> "" Then
  Cells(rowNumberValue - 1, 45) = J_TODAY(1)
    End If

End Sub 

وقتی شما اطلاعات رو زیرهم وارد کنید تاریخ نمیزنه حتما باید بعد از وارد کردن اطلاعات به سلول کناریش برید تا تاریخ ثبت بشه

[sabertb]

میدونید علت این کد نویسی چیه ؟ علتش اینه که روش وارد کردن اطلاعات ممکنه هم کنار هم باشه یعنی به صورت سطری وارد بشه هم به صورت ستونی زیر هم کم پیش میاد به صورت ستونی بالای هم وارد بشه

حالا اگه بخواهیم این وار کردن اطلاعات مشکلی برای تاریخ های بالا و پایین سلول متناظر پیش نیاره چه باید کرد

[Amir Ghasemiyan]

چیزی که من از کد شما متوجه شدم اگه درست باشه شما نیاز به هیچ کدوم از اون کدها ندارین
فقط همین چند خط کد کافیه:

Sub Worksheet_Change(ByVal Target As Range)
Cells(Target.Row, Target.Column + 23) = J_TODAY(1)
End Sub

[sabertb]

دست شما درد نکنه
فقط ت ماژول تاریخ نمی دونم چرا اررور میده

Function J_TODAY(Optional mode As Integer)

    Application.Volatile True
    Dim x1 As New DateClass
    x1.Initial
    
    If mode = 1 Then
        
        J_TODAY = FDate(x1.JToday("long"))
    Else
        J_TODAY = FDate(x1.JToday("Short"))
    End If

End Function 

[sabertb]

چیزی که من از کد شما متوجه شدم اگه درست باشه شما نیاز به هیچ کدوم از اون کدها ندارین
فقط همین چند خط کد کافیه:

Sub Worksheet_Change(ByVal Target As Range)
Cells(Target.Row, Target.Column + 23) = J_TODAY(1)
End Sub

یه مشکلم که هست اینه وقتی اطلاعات رو تو سل ها کپی میکنم یا از یک سل میگیرم و تامیم میدم به بقلی ها و زیری ها جواب نمیده بعلاوه اررو که از تاریخ میگیره

[Amir Ghasemiyan]

دست شما درد نکنه
فقط ت ماژول تاریخ نمی دونم چرا اررور میده

Function J_TODAY(Optional mode As Integer)

    Application.Volatile True
    Dim x1 As New DateClass
    x1.Initial
    
    If mode = 1 Then
        
        J_TODAY = FDate(x1.JToday("long"))
    Else
        J_TODAY = FDate(x1.JToday("Short"))
    End If

End Function 

من تست کردم مشکلی نداشت. کدهاتون رو پاک کنید از اول وارد کنین. فایل رو هم ببندید دوباره باز کنید

[Amir Ghasemiyan]

یه مشکلم که هست اینه وقتی اطلاعات رو تو سل ها کپی میکنم یا از یک سل میگیرم و تامیم میدم به بقلی ها و زیری ها جواب نمیده بعلاوه اررو که از تاریخ میگیره

من فکر کردم فقط دستی داده وارد میکنید. اگه قرار باشه کپی کنید یا فیل کنید یک حلقه نیاز دارید. من تست کردم این برنامه کاملا جواب میده مشکلی نداره

Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
For Each cell In Selection
    If Not Intersect(Target, Selection) Is Nothing Then Cells(cell.Row, cell.Column + 23) = J_TODAY(1)
Next
End Sub