إنشاء فولدرات باسماء الموظفين والعقود

[𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ]

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

كل عام وانتم بالخير بمناسبة الاسراء والمعراج

محتاج مساعدة بالاكواد في الملف المرفق اعزكم الله

اريد إنشاء مجلدات لعدد من الموظفين

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

2- ان يتم إنشاء مجلد باسم العقد سواء ثابت او مؤقت 

3- يتم ترحيل مجلد الموظف داخل مجلد العقد 

بمعنى اذا وجد الموظف العقد ثابت يتم إنشاء الفولدر داخل مجلد ثابت ومثله في المؤقت

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

عقود.xlsb

[محمد هشام.]

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

جرب هل هدا ما تقصده 

Option Explicit
Sub CreateDossiers()
    Dim a As Variant, lastRow As Long, i As Long
    Dim folderPath As String, Dossier As String, ky As String
    Dim nCarte As String, nEmploy As String, tyCont As String
    Dim ScrWS As Worksheet: Set ScrWS = Sheets("ورقة1")
    
    lastRow = ScrWS.Cells(ScrWS.Rows.Count, "b").End(xlUp).Row
    a = ScrWS.Range("B2:D" & lastRow).Value
    
    folderPath = ThisWorkbook.Path & "\"
    If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath
    
    For i = 1 To UBound(a, 1)
        nCarte = Trim(a(i, 1)): nEmploy = Trim(a(i, 2)): tyCont = Trim(a(i, 3))
        
        If nCarte <> "" And IsNumeric(nCarte) And nEmploy <> "" And tyCont <> "" Then
            Dossier = folderPath & tyCont & "\"
            If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier
                ky = Dossier & nCarte & " - " & nEmploy & "\"
                If Dir(ky, vbDirectory) = "" Then MkDir ky
        End If
    Next i
    
    MsgBox "تم إنشاء المجلدات بنجاح", vbInformation
End Sub

 

 

عقود V1.xlsb

[𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ]

الان, محمد هشام. said:

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

جرب هل هدا ما تقصده 

Option Explicit
Sub CreateDossiers()
    Dim a As Variant, lastRow As Long, i As Long
    Dim folderPath As String, Dossier As String, ky As String
    Dim nCarte As String, nEmploy As String, tyCont As String
    Dim ScrWS As Worksheet: Set ScrWS = Sheets("ورقة1")
    
    lastRow = ScrWS.Cells(ScrWS.Rows.Count, "b").End(xlUp).Row
    a = ScrWS.Range("B2:D" & lastRow).Value
    
    folderPath = ThisWorkbook.Path & "\"
    If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath
    
    For i = 1 To UBound(a, 1)
        nCarte = Trim(a(i, 1)): nEmploy = Trim(a(i, 2)): tyCont = Trim(a(i, 3))
        
        If nCarte <> "" And IsNumeric(nCarte) And nEmploy <> "" And tyCont <> "" Then
            Dossier = folderPath & tyCont & "\"
            If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier
                ky = Dossier & nCarte & " - " & nEmploy & "\"
                If Dir(ky, vbDirectory) = "" Then MkDir ky
        End If
    Next i
    
    MsgBox "تم إنشاء المجلدات بنجاح", vbInformation
End Sub

مرورك كريم ا. محمد

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

الكود يعمل بشكل جيد ولي استفسار بخصوص عدم السماح بتكرار اسم المجلد لنفس الموظف 

ممكن اضافة عدم السماح بانشاء اكثر من مجلد للموظف 

وشكرا لحضرتك

 

عقود V1.xlsb 18.09 kB · 2 downloads

 

[محمد هشام.]

 

منذ ساعه, 𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ said:

ممكن اضافة عدم السماح بانشاء اكثر من مجلد للموظف 

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

لنفترض ان البيانات بهدا الشكل  ما هي المجلدات المفروض إنشائها 

ثايت = ؟

مؤقت = ؟

[𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ]

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

 

[محمد هشام.]

  إدا كنت قد إستوعبت طلبك بشكل صحيح ربما هدا سيوفي بالغرض  

 

Option Explicit
Sub CreateDossiers()
    Dim a As Variant, lastRow As Long, i As Long, msg As String
    Dim Dossiers As String, Fld As String, Patch As String
    Dim nCarte As String, nEmploy As String, tyCont As String
    Dim tbl As Object, Fname As String, fCount As Integer
    Dim ScrWS As Worksheet: Set ScrWS = Sheets("ورقة1")
    
    Set tbl = CreateObject("Scripting.Dictionary")
    lastRow = ScrWS.Cells(ScrWS.Rows.Count, "B").End(xlUp).Row
    If lastRow < 2 Then Exit Sub

    a = ScrWS.Range("B2:D" & lastRow).Value
    Dossiers = ThisWorkbook.Path & "\"

    Fld = Dossiers & "عقد ثابت\"
    Patch = Dossiers & "عقد مؤقت\"
    If Dir(Dossiers, vbDirectory) = "" Then MkDir Dossiers
    If Dir(Fld, vbDirectory) = "" Then MkDir Fld
    If Dir(Patch, vbDirectory) = "" Then MkDir Patch
    
    For i = 1 To UBound(a, 1)
        If Trim(a(i, 3)) = "ثابت" Then
            tbl(Trim(a(i, 1)) & " - " & Trim(a(i, 2))) = "ثابت"
        End If
    Next i

    fCount = 0
    For i = 1 To UBound(a, 1)
        nCarte = Trim(a(i, 1)): nEmploy = Trim(a(i, 2)): tyCont = Trim(a(i, 3))
        
        If nCarte <> "" And IsNumeric(nCarte) And nEmploy <> "" And tyCont <> "" Then
            Fname = nCarte & " - " & nEmploy
            
            If tbl.Exists(Fname) Then
                If Dir(Fld & Fname, vbDirectory) = "" Then
                    MkDir Fld & Fname
                    fCount = fCount + 1
                End If
            Else
                If Dir(Patch & Fname, vbDirectory) = "" Then
                    MkDir Patch & Fname
                    fCount = fCount + 1
                End If
            End If
        End If
    Next i

    msg = IIf(fCount > 0, "تم إنشاء " & fCount & " من المجلدات بنجاح", "جميع المجلدات موجودة مسبقا")
    MsgBox msg, vbInformation
End Sub

 

 

عقود V2.xlsb

تم تعديل الثلاثاء at 15:59 بواسطه محمد هشام.

[𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ]

شكرا ا. محمد على اهتمامك

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