تقسيم و انشاء اوراق عمل لاشهر السنة

[𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ]

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

كل عام وانتم بخير

احتاج مساعد في الملف المرفق 

اريد تقسيم الموظفين بناء على التاريخ في العمود J الى ورقة عمل جديدة تحتوى على اشهر السنة وان يضع كل موظف تاريخ انتهاء العقد الخاص به طبقا للشهر

اريد ان يتم إنشاء ملف جديد يحتوى على 12 شهر ( ورقه عمل ) وان يكون هناك ورقة عمل اسمها ملخص يذكر فيه اجمالي الموظفين لكل شهر

وشكرا لكم 

العقود.xlsx

[محمد هشام.]

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

جرب هدا 

Option Explicit
Sub SplitData()
    Dim crWS As Worksheet, dest As Worksheet, OnRng As Variant, data As Variant
    Dim n As Integer, x As Integer, MonthArr As String, sDate As Date
    Dim lastRow As Long, i As Long, Irow As Long, lr As Long
    Dim f As Worksheet, arr As Variant, v As Variant: Set crWS = Sheets("العقود")
    arr = Array("العقود", "")   ' في حالة وجود أوراق أخرى يجب الإحتفاظ بها قم بإظافتها هنا 
   
    lastRow = crWS.Cells(crWS.Rows.Count, "J").End(xlUp).Row
    If lastRow < 5 Then: Exit Sub
    
        With Application
            .ScreenUpdating = False: .DisplayAlerts = False
        End With

   Application.ErrorCheckingOptions.BackgroundChecking = True
    For Each f In ThisWorkbook.Worksheets
        If f.Name <> crWS.Name Then
            v = Application.Match(f.Name, arr, 0)
            If IsError(v) Then: f.Delete
        End If
    Next f
    
    OnRng = crWS.Range("J4:J" & lastRow).Value
    For i = 1 To UBound(OnRng, 1)
        If InStr(OnRng(i, 1), ":") > 0 Then OnRng(i, 1) = Replace(OnRng(i, 1), ":", "/")
    Next i

    crWS.Range("J4:J" & lastRow).Value = OnRng
    For i = 1 To UBound(OnRng, 1)
        If Len(OnRng(i, 1)) > 0 Then
            If IsDate(OnRng(i, 1)) Then
                sDate = CDate(OnRng(i, 1)): n = Month(sDate): x = Year(sDate)
                MonthArr = Choose(n, "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _
                                   "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر")
           
           Set dest = tmp(MonthArr & " " & x, crWS.Rows(4))
            Irow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1
            data = crWS.Range("B" & (i + 3) & ":N" & (i + 3)).Value
            dest.Range("B" & Irow).Resize(1, UBound(data, 2)).Value = data

            With dest.Range("A5:A" & dest.Cells(dest.Rows.Count, "J").End(xlUp).Row)
                .Value = Evaluate("ROW(" & .Address & ")-4")
            End With
  
            With dest
                lr = .Columns("A:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
                .Columns("A:M").AutoFit
                .Rows("5:" & lr).RowHeight = 25.5
                .Range("A5:M" & lr).HorizontalAlignment = xlCenter
                .Range("A5:M" & lr).VerticalAlignment = xlCenter
                .Range("J5:J" & lr).NumberFormat = "dd/mm/yyyy"
                

            End With
        End If
    End If
Next i

    crWS.Activate
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    MsgBox "تم تقسيم الموظفين بنجاح", vbInformation
End Sub
Function tmp(ShName As String, header As Range) As Worksheet
    Dim WS As Worksheet
    On Error Resume Next
    Set WS = ThisWorkbook.Sheets(ShName)
    On Error GoTo 0
    If WS Is Nothing Then
        Set WS = Sheets.Add(After:=Sheets(Sheets.Count))
        WS.Name = ShName
        WS.DisplayRightToLeft = True
        header.Copy WS.Rows(4)
    End If
    Set tmp = WS
End Function

 

العقود v2.xlsb

تم تعديل فبراير 11 بواسطه محمد هشام.

[mahmoud nasr alhasany]

احسنت استاذنا الغالى / محمد هشام

يوجد ملحوظة بسيطة وهى عند تقسيم الموظفين بناء على التاريخ يظهر تنسيق بيانات التاريخ ارقام فى اعمدة معينة

وهذا الكود المعدل البسيط بعد اذن استاذنا 

Option Explicit

Sub SplitData()
    Dim crWS As Worksheet, dest As Worksheet, OnRng As Variant, data As Variant
    Dim n As Integer, x As Integer, MonthArr As String, sDate As Date
    Dim lastRow As Long, i As Long, Irow As Long, lr As Long
    Dim f As Worksheet, arr As Variant, v As Variant
    Dim dateCol As String ' لتخزين حرف عمود التاريخ

    Set crWS = Sheets("العقود")
    dateCol = "J" ' حدد حرف عمود التاريخ هنا

    arr = Array("العقود", "")

    lastRow = crWS.Cells(crWS.Rows.Count, dateCol).End(xlUp).Row
    If lastRow < 5 Then Exit Sub

    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
        .Calculation = xlCalculationManual ' تعطيل العمليات الحسابية للتسريع
    End With

    Application.ErrorCheckingOptions.BackgroundChecking = True

    For Each f In ThisWorkbook.Worksheets
        If f.Name <> crWS.Name Then
            v = Application.Match(f.Name, arr, 0)
            If IsError(v) Then f.Delete
        End If
    Next f

    OnRng = crWS.Range(dateCol & "4:" & dateCol & lastRow).Value

    ' تصحيح تحويل التاريخ وتنسيقه *قبل* الكتابة إلى الورقة
    For i = 1 To UBound(OnRng, 1)
        If Len(OnRng(i, 1)) > 0 Then
            ' التعامل مع تنسيقات التاريخ المختلفة (بما في ذلك مع وجود نقطتين)
            If InStr(OnRng(i, 1), ":") > 0 Then OnRng(i, 1) = Replace(OnRng(i, 1), ":", "/")
            If IsDate(OnRng(i, 1)) Then
                sDate = CDate(OnRng(i, 1))
                n = Month(sDate)
                x = Year(sDate)
                MonthArr = Choose(n, "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _
                                   "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر")

                Set dest = tmp(MonthArr & " " & x, crWS.Rows(4))
                Irow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1
                data = crWS.Range("B" & (i + 3) & ":N" & (i + 3)).Value

                ' كتابة البيانات
                dest.Range("B" & Irow).Resize(1, UBound(data, 2)).Value = data

                ' تعيين تنسيق التاريخ *مباشرة* بعد كتابة التاريخ
                dest.Cells(Irow, dateCol).NumberFormat = "dd/mm/yyyy" ' تنسيق عمود التاريخ المحدد

                ' تنسيق الأعمدة H و I و K
                dest.Cells(Irow, "H").NumberFormat = "dd/mm/yyyy"
                dest.Cells(Irow, "I").NumberFormat = "dd/mm/yyyy"
                dest.Cells(Irow, "K").NumberFormat = "dd/mm/yyyy"

                With dest.Range("A5:A" & dest.Cells(dest.Rows.Count, dateCol).End(xlUp).Row) ' استخدام dateCol هنا أيضًا
                    .Value = Evaluate("ROW(" & .Address & ")-4")
                End With

                With dest
                    lr = .Columns("A:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
                    .Columns("A:M").AutoFit
                    .Rows("5:" & lr).RowHeight = 25.5
                    .Range("A5:M" & lr).HorizontalAlignment = xlCenter
                    .Range("A5:M" & lr).VerticalAlignment = xlCenter
                    ' لا حاجة لتعيين تنسيق الرقم للعمود بأكمله هنا، فقد تم بالفعل
                End With
            End If
        End If
    Next i

    crWS.Activate
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic ' إعادة تمكين العمليات الحسابية
    End With
    MsgBox "تم تقسيم الموظفين بنجاح", vbInformation
End Sub

Function tmp(ShName As String, header As Range) As Worksheet
    Dim WS As Worksheet
    On Error Resume Next
    Set WS = ThisWorkbook.Sheets(ShName)
    On Error GoTo 0
    If WS Is Nothing Then
        Set WS = Sheets.Add(After:=Sheets(Sheets.Count))
        WS.Name = ShName
        WS.DisplayRightToLeft = True
        header.Copy WS.Rows(4)
    End If
    Set tmp = WS
End Function

 

 

 

العقود.xlsm

تم تعديل فبراير 12 بواسطه mahmoud nasr alhasany

[𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ]

ماشاء الله ا. محمد هشام

تسلم ايديك الكود يعمل بكفائه ولكن لم يقم بنسخ نفس التنسق

هل ممكن تعديل الكود ليقوم بنسخ نفس التنسيق

ربنا يجزيك كل خير ويزيديك من فضله وعلمه

تم تعديل فبراير 12 بواسطه 𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ

[mahmoud nasr alhasany]

لقد ارفقت لك الملف

 

[𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ]

20 دقائق مضت, mahmoud nasr alhasany said:

لقد ارفقت لك الملف

 

شكرا لك ا. محمود

بارك الله فيك

[محمد هشام.]

يمكنك إظافة السطور التالية لتحديد التنسيق الدي يناسبك 

Dim ColArr As Variant, col As Variant
ColArr = Array("H", "I", "J", "K")
 For Each col In ColArr
   With dest.Range(col & "5:" & col & dest.Rows.Count)
       .NumberFormat = "dd/mm/yyyy"
    End With
 Next col

 

العقود v3.xlsb

[𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ]

شكرا لحضرتك ا. محمد هشام

بارك الله فيك

كلمة شكر لا تكفي لمجهوداتك في المنتدى

جزاك الله كل خير انت وجميع الاخوة الافاضل في المنتدى