كود تغيير تنسيق التاريخ مع الترتيب والتصفية المتقدمة.

[خالدو]

السلام عليكم ورحمة الله وبركاته إخواني وأخواتي بمنتدى أوفيسنا العظيم.

 

أسأل الله العلي القدير أن ينصر أهلينا في غزة العزة والصمود على أعدائهم وعلى من خذلهم وأن يتقبل الله منا ومنكم الصيام والقيام وصالح الأعمال.

 

ثم أرجو التكرم بكود يحول تنسيق التاريخ كما هو موضح بالملف المرفق ثم عمل تصفية لاستبعاد المكرر ثم الترتيب من الأقدم للأحدث في نفس العمود.

 

وجزاكم الله خيراً

Book1.zip

[عبدالله باقشير]

السلام عليكم

 

جرب هذا على السريع  بدون حذف المكرر

Sub Macro1()
Dim cel As Range
On Error GoTo 1
With Range(Range("A1"), Range("A1").End(xlDown))
    For Each cel In .Cells
        cel.Value = Split(CStr(cel), ".")(1) & "/" & Split(CStr(cel), ".")(0) & "/" & Split(CStr(cel), ".")(2)
    Next
    .Sort .Columns(1), xlAscending
End With
1:
End Sub

تحياتي

[خالدو]

مشكور أخي الحبيب عبد الله ... كود رائع جداً.

فعلاً تم التحويل والترتيب.

أرجو التكرم بكود لحذف المكرر إن أمكن لأن الملفات الأخرى بها سجلات مكررة.

 

جزاك الله خيراً

[عبدالله باقشير]

مشكور أخي الحبيب عبد الله ... كود رائع جداً.

فعلاً تم التحويل والترتيب.

أرجو التكرم بكود لحذف المكرر إن أمكن لأن الملفات الأخرى بها سجلات مكررة.

 

جزاك الله خيراً

 

جزاكم الله خيرا

هذا مع حذف المكرر

Sub Macro1()
Dim cel As Range, ArRng As Range
Dim i As Long
On Error GoTo 1
With Range(Range("A1"), Range("A1").End(xlDown))
    For Each cel In .Cells
        i = i + 1
        cel.Value = Split(CStr(cel), ".")(1) & "/" & Split(CStr(cel), ".")(0) & "/" & Split(CStr(cel), ".")(2)
        If WorksheetFunction.CountIf(.Cells.Resize(i, 1), cel.Value) = 2 Then
            If ArRng Is Nothing Then Set ArRng = cel Else Set ArRng = Union(ArRng, cel)
        End If
    Next
    If Not ArRng Is Nothing Then ArRng.Delete
    .Sort .Columns(1), xlAscending
End With
1:
Set ArRng = Nothing
End Sub

تحياتي

[خالدو]

أخي الحبيب الكود الأخير لم يحذف المكرر وارفع لكم الملف الذي يحوي التكرار.

 

Book2.zip

[عبدالله باقشير]

السلام عليكم

جرب هذا

Sub Macro1()
Dim cel As Range, ArRng As Range
Dim i As Long
On Error GoTo 1
With Range(Range("A1"), Range("A1").End(xlDown))
    For Each cel In .Cells
        i = i + 1
        cel.Value = Split(CStr(cel), ".")(1) & "/" & Split(CStr(cel), ".")(0) & "/" & Split(CStr(cel), ".")(2)
        If WorksheetFunction.CountIf(.Cells.Resize(i, 1), cel.Value) >= 2 Then
            If ArRng Is Nothing Then Set ArRng = cel Else Set ArRng = Union(ArRng, cel)
        End If
    Next
    If Not ArRng Is Nothing Then ArRng.Delete
    .Sort .Columns(1), xlAscending
End With
1:
Set ArRng = Nothing
End Sub

تحياتي

[جمال عبد السميع]

ماشاء الله أستاذى " عبد الله بقشير"

أعمال رائعة تخلد لأستاذ

وأسمح لتلميذك

لهواة " المعادلات " ومحبيها ، أن يكون لهم نصيب

وبالطبع أعلم أن صاحب السؤال سيفضل الكود ، ولكنى أعلم أيضا أن للمعادلات عشاقها مثلى ، وأعلم أيضا أن كثير من زملائى تمنوا أن يكون هناك حلان

بالأكواد ، والمعادلات

لذلك أقدم هذا الحل المتواضع بالمعادلات لعل يكون به الأفادة

تقبلوا تحياتى

 

تنسيق تاريخ وتصفية وحذف المكرر.rar

[جمال عبد السميع]

حل أخر بدون أكواد أو معادلات

1- ظلل كامل العمود الذى يحتوى على التواريخ

2- من قائمة "DATA" إختر "Delimited" --> إختر "NEXT "

3- إختر "DATE "  ثم إختر " COLUMN DATA FORMAT " إختر "  MDY, DMY..".ثم format ثم --> Finish

ولحذف التكرارات:

1- من نفس القائمة  "DATA" قف على الخلية الأولى فى العمود إختر " SORT " ثم "ascending أو descending " ونظرا لانك تحتاج من الأقدم للأحدث ascending

تقبل تحياتى

[خالدو]

جزاكم الله خيراً أخي عبد الله وأخي جمال.

 

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

 

عملت إضافة بسيطة لكود الأخ الفاضل عبد الله والحمد لله تم المطلوب.

 

الكود بعد الإضافة:

 

Sub Macro1()
With ThisWorkbook.Sheets("Sheet2")
Dim cel As Range, ArRng As Range
Dim i As Long
Dim r As Range
On Error GoTo 1
With ThisWorkbook.Sheets("Sheet2").Range(Range("A1"), Range("A1").End(xlDown))
    For Each cel In .Cells
        i = i + 1
        cel.Value = Split(CStr(cel), ".")(1) & "/" & Split(CStr(cel), ".")(0) & "/" & Split(CStr(cel), ".")(2)
        If WorksheetFunction.CountIf(.Cells.Resize(i, 1), cel.Value) = 2 Then
            If ArRng Is Nothing Then Set ArRng = cel Else Set ArRng = Union(ArRng, cel)
        End If
    Next
    If Not ArRng Is Nothing Then ArRng.Delete
    .Sort .Columns(1), xlAscending
    LR = Cells(Cells.Rows.Count, "A").End(xlUp).Row
    Set r = Range("A1:A" & LR)
    r.RemoveDuplicates Columns:=Array(1), Header:=xlNo
End With
1:
Set ArRng = Nothing
End With
   
End Sub
 

وأكرر الشكر وأسأل الله أن ينفع بكم المسلمين وأن يتقبل منا ومنكم صالح الأعمال