جلب بيانات من جدول الموظفين إلى نموذج الأجازات

[احمد العدوى]

اجازات موظفين.rarاجازات موظفين.rarالمطلوب جلب بيانات من جول الموظفين إلى نموزج الأجازات

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

أخي الكريم أحمد العدوي

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

تقبل تحياتي

[احمد العدوى]

شكرا أخى الفاضل ياسر

رفع الملف

 

اجازات موظفين.rar

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

وعليكم السلام أخي الكريم أحمد

لاحظت أنك تضع ردود في بعض الأحيان تكون فارغة من أي محتوى ..إذا كنت تريد رفع الموضوع فاكتب كلمة للرفع فقط ..

وأفضل دائماً في حالة أن الموضوع لا يوجد استجابة له أن تزيد من التفصيل للطلب لتتضح الصورة أكثر

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

تقبل تحياتي

[احمد العدوى]

السلام عليكم

أخى الفاضل/ ياسر

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

وشكراً على حسن اهتمامكم

خالص احترامى وتقديرى

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

أخي الكريم أحمد العدوي

ضع الكود التالي في موديول عادي

Sub ReportVacation()
    Const RowOfDates_Data As Long = 6
    Const V_1C As String = "اعتيادى", V_2C As String = "عارضة", V_3C As String = "مرضى"
    
    Dim I As Long, J As Long, Col As Long
    Dim NameToReport As String, VacClass As String
    Dim FirstRowOfDates_Report As Long, FirstColumnOfDates_Report As Long, NamerOffset As Long
    Dim ColumnOfDates_Report As Long
    Dim EndColumnOfVac_PossibleRunOn As Long
    Dim rNameToCheck_Data As Long, cVacToCheck_Data_1st As Long, cVacToCheck_Data_Last As Long
    Dim VacRunOns() As Long
    
    Dim WS As Worksheet
    Dim Col_1C As Collection, Col_2C As Collection, Col_3C As Collection, Col_x As Collection, Col_y As Collection
    
    Set Col_1C = New Collection
    Set Col_2C = New Collection
    Set Col_3C = New Collection
    
    Set Col_x = New Collection
    Set Col_y = New Collection
    Set WS = ThisWorkbook.Worksheets("Sheet1")
    
    WS.Range("B12:C36,G12:H36,L12:M36").ClearContents
    
    cVacToCheck_Data_1st = 19
    
    For I = 0 To WS.Cells(7, 18).End(xlDown).Row - 7
        If WS.Cells(5, 2) = WS.Cells(I + 7, 18) Then
            rNameToCheck_Data = I + 1 + RowOfDates_Data
            Exit For
        End If
    Next I
    
    If rNameToCheck_Data = Empty Then MsgBox ("خطأ: الاسم غير موجود" & vbCr & "التأكد من الاسم: " & WS.Cells(5, 2).Value)
    
    Do While WS.Cells(rNameToCheck_Data, cVacToCheck_Data_1st).End(xlToRight).Column < 50
        If WS.Cells(rNameToCheck_Data, cVacToCheck_Data_1st).Value = Empty Then
            cVacToCheck_Data_1st = WS.Cells(rNameToCheck_Data, cVacToCheck_Data_1st).End(xlToRight).Column
        End If
        
        If WS.Cells(rNameToCheck_Data, cVacToCheck_Data_1st + 1) = WS.Cells(rNameToCheck_Data, cVacToCheck_Data_1st) Then
            cVacToCheck_Data_Last = WS.Cells(rNameToCheck_Data, cVacToCheck_Data_1st).End(xlToRight).Column
        Else
            cVacToCheck_Data_Last = cVacToCheck_Data_1st
        End If
        
        ReDim VacRunOns(0)
        
        VacRunOns(0) = cVacToCheck_Data_1st
        If cVacToCheck_Data_1st < cVacToCheck_Data_Last Then
            For Col = cVacToCheck_Data_1st + 1 To cVacToCheck_Data_Last
                If WS.Cells(rNameToCheck_Data, Col - 1) <> WS.Cells(rNameToCheck_Data, Col) Then
                    ReDim Preserve VacRunOns(UBound(VacRunOns) + 1)
                    VacRunOns(UBound(VacRunOns)) = Col
                End If
            Next Col
        End If
        
        For I = 0 To UBound(VacRunOns)
            VacClass = WS.Cells(rNameToCheck_Data, VacRunOns(I))
            
            If I < UBound(VacRunOns) Then
                EndColumnOfVac_PossibleRunOn = VacRunOns(I + 1) - 1
            Else
                EndColumnOfVac_PossibleRunOn = cVacToCheck_Data_Last
            End If
            
            Select Case VacClass
                Case V_1C
                    Col_1C.Add AssignDatesToCollection(WS.Cells(RowOfDates_Data, VacRunOns(I)), WS.Cells(RowOfDates_Data, EndColumnOfVac_PossibleRunOn))
                Case V_2C
                    Col_2C.Add AssignDatesToCollection(WS.Cells(RowOfDates_Data, VacRunOns(I)), WS.Cells(RowOfDates_Data, EndColumnOfVac_PossibleRunOn))
                Case V_3C
                    Col_3C.Add AssignDatesToCollection(WS.Cells(RowOfDates_Data, VacRunOns(I)), WS.Cells(RowOfDates_Data, EndColumnOfVac_PossibleRunOn))
                Case Else
                    MsgBox (" خطأ في نوع الأجازة" & VacClass & " غير موجودة")
            End Select
        Next I
        
        cVacToCheck_Data_1st = EndColumnOfVac_PossibleRunOn + 1
    Loop
    
    FirstRowOfDates_Report = 12
    FirstColumnOfDates_Report = 2
    
    For I = 0 To 2
        If I = 0 Then
            If Col_1C.Count > 0 Then Set Col_y = Col_1C
            ElseIf I = 1 Then
            If Col_2C.Count > 0 Then Set Col_y = Col_2C
            ElseIf I = 2 Then
            If Col_3C.Count > 0 Then Set Col_y = Col_3C
        End If
        
        For J = 1 To Col_y.Count
            Set Col_x = Col_y.Item(J)
            WS.Cells(FirstRowOfDates_Report + J - 1, FirstColumnOfDates_Report + 5 * I) = Col_x.Item(1)
            WS.Cells(FirstRowOfDates_Report + J - 1, FirstColumnOfDates_Report + 5 * I + 1) = Col_x.Item(2)
            If J = Col_y.Count Then Set Col_y = New Collection
        Next J
    Next I
End Sub

Private Function AssignDatesToCollection(StartD As Date, EndD As Date) As Collection
    Dim Output As Collection
    Set Output = New Collection
    
    Output.Add StartD
    Output.Add EndD
    
    Set AssignDatesToCollection = Output
End Function

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

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("B5")) Is Nothing Then
        Call ReportVacation
    End If
End Sub

تقبل وافر تقديري واحترامي

اجازات موظفين.rar

[احمد العدوى]

بسم الله ماشاء الله

        اللهم صلى على النبى 

                                       حاجة جميلة جداً

                                                   تسلم إيدك يأبو البراء ياغالى

                                                                                              جزاكم الله خيرا و  أصلح الله حالك وأصلح مابين يديك

                                                                                                                                                                               ودائماً فى مزيد

                                                       

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

أخي الكريم أحمد

اللهم صل وسلم وبارك على سيد الخلق سيدنا محمد صلى الله عليه وسلم

وجزيت خير الجزاء بمثل ما دعوت لي ...

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

تقبل تحياتي