تحويل التاريخ من يوم 1 إلى يوم الأحد

[khairi ali]

السلام عليكم 

لو تكرمتم الرجاء الاجابة على السؤال في الملف المرفق

وشكرا

المصنف1.xlsm

[سليم حاصبيا]

ربما يكون الحل

Option Explicit

Sub Get_days()
Dim i%, k%, m%, it
Dim arr(), cont
Dim st$
Dim Days_num%
Dim arr_arab(1 To 7)
 arr_arab(1) = "الأحد": arr_arab(2) = "الإثنين": arr_arab(3) = "الثلاثاء"
 arr_arab(4) = "الأربعاء": arr_arab(5) = "الخميس": arr_arab(6) = "الجمعة"
 arr_arab(7) = "السّبت"
Dim dict As Object
 m = 1
Set dict = CreateObject("Scripting.Dictionary")
For i = 5 To 16
      If Range("c" & i) <> "" Then
    With dict
       cont = Split(Range("c" & i), "-")
      .Add i - 4, cont
         For Each it In .Items
           ReDim Preserve arr(1 To 1)
           arr(1) = it
           Range("e" & i) = UBound(cont) + 1
             For k = UBound(cont) To 0 Step -1
             Days_num = Weekday(DateSerial([E2], i - 4, cont(k)))
            st = st & arr_arab(Days_num) & ","
              Range("g" & i) = Left(st, Len(st) - 1) & "."
             Next
         Next
         .RemoveAll
         Erase arr
         st = vbNullString
    End With
  End If
 Next

End Sub

الملف مرفق

 

khairi ali.xlsm

[khairi ali]

مشكور أستاذ سليم 

ولكن هناك خطأ

عندما قمت بتغير السنة إلى 2018 ظهر الخطأ كما في الصورة 

[وجيه شرف الدين]

ما شاء الله استاذ سليم كود فى عاية الجمال والروعة بعد اذن استاذ سليم ضيف هذه الجمله فى اول الكود         On Error Resume Next

[سليم حاصبيا]

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

المطلوب فقط ان تترك الخلية فارغة ولا يتم وضع   لا  " 0"  ولا   " -" ولا   اي شيء آخر

يتم ادراج فقط ارقام من 1 الى نهاية الشهر حسب الخلية المناسبة   في العامود   C    يتوسط الرقمين   "-"

للتوضيح 

هذه الصورة

 

[احمد بدره]

رائع أستاذنا الفاضل الأستاذ / سليم

أرى أن يتم استبدال العلامة "-" بفاصلة " ,"لأنه أحيانًا لو كان الغياب يومان يتحول إلى تاريخ 

وقم بتجربتها فكانت بلا مشاكل

 

khairi ali.xlsm

[khairi ali]

مشكورين جدا على هذا التوضيح

[سليم حاصبيا]

هذا ملف اخر  لا يأخذ بعين الاعتبار    ما تحتويه الخلايا  (فقط ينظر الى الارقام بين 1 و نهاية الشهر)

ولا ينظر الى الفواصل اي كانت (فواصل  نص  * \ /  الخ.....)

Option Explicit
Sub Saerch_date()
  Dim regex As Object, str As String
  Set regex = CreateObject("VBScript.RegExp")
      
      With regex
      .Global = True
      .IgnoreCase = True
      .Pattern = "([1-3]?\d+)"
      End With
      
  Dim MY_Match, x%, s$, i%, m%: m = 1
  Dim Days_num$, Final_Month%
  Dim my_array()
  Dim arr_arab(1 To 7)
    arr_arab(1) = "الأحد": arr_arab(2) = "الإثنين"
    arr_arab(3) = "الثلاثاء": arr_arab(4) = "الأربعاء"
    arr_arab(5) = "الخميس": arr_arab(6) = "الجمعة"
    arr_arab(7) = "السّبت"
  Range("E5:E16,G5:G16").ClearContents
 For i = 5 To 16
  Set MY_Match = regex.Execute(Range("c" & i))
   If MY_Match.Count = 0 Then GoTo next_i
  For x = MY_Match.Count - 1 To 0 Step -1
  Final_Month = Month(DateSerial([E2], i - 4, MY_Match(x)))
   If Final_Month = i - 4 Then
   Days_num = Weekday(DateSerial([E2], i - 4, MY_Match(x)))
   ReDim Preserve my_array(1 To m)
    my_array(m) = arr_arab(Days_num)
    m = m + 1
 End If
Next x
 Range("E" & i) = m - 1
s = Join(my_array, ",")
Range("G" & i) = s
s = "": m = 1: Erase my_array
next_i:
Next
 Set regex = Nothing
 Erase arr_arab
End Sub

الملف مرفق

 

 

khairi ali_Extra.xlsm

[khairi ali]

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

اشكر كل من ساهم في المرور على هذا الموضوع قدم المساعدة

لدي سؤال اخر وهو حساب تكرر أيام الغياب ولكم مني جزيل الشكر والتقدير

حساب تكرر أيام الغياب.xlsm

[احمد بدره]

بارك الله فيك أستاذنا الفاضل والمبدع دائمًا نتعلم من الكثير 

عمل في غاية الروعة

[سليم حاصبيا]

في الخلية  I5  هذه المعادلة ( Ctrl+Shift+Enter)

=SUM(--(ISNUMBER(FIND(I$3,$G$5:$G$16))))

 

tekrar 8yab.xlsm

[khairi ali]

مشكور جدا أخي سليم

لو سمحت حساب التكرر لكل شهر على حده

 

[سليم حاصبيا]

تم معالجة الأمر

 

tekrar 8yab _Month.xlsm

[khairi ali]

بارك الله فيك أستاذ سليم

[سليم حاصبيا]

مزيد المزيد في هذا الملف مع الشرح الوافي

 

 

UDF_tekrar 8yab .xlsm

[وجيه شرف الدين]

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