اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


الردود الموصى بها

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

 

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

 

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

 

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

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

تحياتي

رابط هذا التعليق
شارك

السلام عليكم


جرب هذا

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
 

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

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information