اختيار الخلية التي قمت بكتابتها سابقا قبل الترتيب

[mohamed elforse]

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

تحية طيبة وبعد ,,,,,

السادة اعضاء المنتدي اريد مساعدة بسيطة جدا في الملف المرفق

تم تصميم الملف بحيث عند كتابة اي تاريخ في عمود F يقوم الكود بالترتيب حسب التاريخ و لكن بعد الترتيب يتم تحديد الخلايا من عمود A حتي اخر شي مكتوب في العمود ثم الي عمود  P

و لكن المطلوب بعد كتابة التاريخ في عمود f و الضغط علي Enter فيقوم الاكسيل بترتيب التاريخ تلقائيا و لكن اريده ان يتم الوقوف علي التاريخ الذي قمت بكتابتة سابقا قبل الضغط علي Enter و ذلك لتكملة البيانات الاخري بعد التاريخ فهل يوجد امكانية لذلك ؟

الملف المرفق : New Microsoft Excel Worksheet2.rar

 

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

وعليكم السلام

أخي الكريم يرجى تغيير اسم الظهور للغة العربية

جرب التعديل التالي في كود حدث التغيير في ورقة العمل

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    
    If Not Intersect(Target, Range("C2:C65536")) Is Nothing Then
        VBA.Calendar = vbCalGreg
        If IsEmpty(Target) Then
            Target(1, 0).ClearContents
        Else
            With Target(1, 0)
                .Value = Format(Date & " " & Time, Text)
                .EntireColumn.AutoFit
            End With
        End If
    End If

    Dim intLR As Integer
    intLR = Cells.SpecialCells(xlLastCell).Row

    If Target.Column = 6 Then
        Dim strdate As String
        Dim rCell As Range

        strdate = Format(Target.Value2, "Short Date")

        'Sort Range
        Range("A1:p" & intLR).Select
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("F2:F" & intLR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Sheet1").Sort
            .SetRange Range("A1:P" & intLR)
            .Header = xlYes
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        On Error Resume Next
            Set rCell = Cells.Find(What:=CDate(strdate), After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
        On Error GoTo 0

        If Not rCell Is Nothing Then rCell.Select: Set rCell = Nothing
    End If

    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("n2:n65536")) Is Nothing Then
        VBA.Calendar = vbCalGreg
        If IsEmpty(Target) Then
            Target(1, 2).ClearContents
        Else
            With Target(1, 2)
                .Value = Format(Date & " " & Time, Text)
                .EntireColumn.AutoFit
            End With
        End If
    End If
End Sub

 

 

[mohamed elforse]

شكرا استاذ ياسر علي المساعدة و نحن نستفيد من خبراتك الرائعة و الكود يعمل بشكل جيد و لكني استخدم هذا الكود لمساعدة شخص اخر بالمنتدي

 

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

الحمد لله أن تم المطلوب على خير والحمد لله الذي بنعمته تتم الصالحات

قم بوضع الرابط للموضوع الذي تقوم بمساعدة الشخص الآخر فيه ليكون هناك ترابط بين الموضوعات

تقبل تحياتي

[mohamed elforse]

Done وقفا لطلب سيادتك

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

الان, mohamed elforse said:

Done وقفا لطلب سيادتك

أين هو رابط الموضوع الآخر؟

[mohamed elforse]