اريد كود يقوم بانشاء فولدر جديد

[إبراهيم ابوليله]

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

[محمد حسن المحمد]

وعليكم السلام ورحمة الله وبركاته أخي الكريم @إبراهيم ابوليله المحترم

أما عن الطلب الأول فقد بحثت عنه وتحققت من أدائه أرجو أن تكون به الفائدة 

الأكواد منقولة من خلال البحث في النت للأمانة.

أما عن الطلب الثاني فالإخوة الكرام أهل لذلك وزيادة (بكم البركة)....

تقبل تحياتي العطرة.

Option Explicit
Dim Status As String

Sub Main()
    
    Dim LastRow As Long, iRow As Long
    Dim FolderPath As String
    Dim wsApp As Worksheet
    
    Set wsApp = ThisWorkbook.Worksheets("App")
    
    With wsApp
        
        LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
        
        FolderPath = .Range("FolderPath").Value
        
        If Dir(FolderPath, vbDirectory) = vbNullString Then
            MsgBox "Invalid Base Folder Provided.", vbExclamation
            Exit Sub
        End If
        
        If 6 > LastRow Then
            MsgBox "No item provided.", vbExclamation
            Exit Sub
        End If
        
        For iRow = 6 To LastRow
            
            If .Cells(iRow, "B").Value <> "" Then
                
                CreateFolder .Cells(iRow, "B").Value, FolderPath
                .Cells(iRow, "C").Value = Status
                
            End If
            
        Next iRow
           
    End With
    
    MsgBox "All folder created successfully.", vbInformation
    
    Set wsApp = Nothing
    
End Sub

Private Sub CreateFolder(ByVal SubFolder As String, ByVal BaseFolder As String)
    
    Dim strTemp As String
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Status = ""

    strTemp = CleanFolderName(SubFolder)
    
    If fso.FolderExists(BaseFolder & "\" & strTemp) Then
        Status = "Folder Exists Already"
    Else
    
        If Len(strTemp) > 0 Then
            
            MkDir BaseFolder & "\" & strTemp
            Status = "Success"
    
        End If
    
    End If

    Set fso = Nothing

End Sub

Public Function CleanFolderName(ByVal FolderName As String) As String
    
    Dim i As Long
    Dim strTemp As String
    
    For i = 1 To Len(FolderName)
        
        Select Case Mid(FolderName, i, 1)
            
            Case "/", "\", ":", "?", "<", ">", "|"
                strTemp = strTemp & "_"
            
            Case Else
                strTemp = strTemp & Mid(FolderName, i, 1)
        
        End Select
    
    Next i
    
    CleanFolderName = strTemp
    
End Function

 

 

 

إبراهيم أبو ليلة.xlsm

[abouelhassan]

مشكور استاذنا بارك الله فيك

[محمد حسن المحمد]

22 دقائق مضت, abouelhassan said:

مشكور استاذنا بارك الله فيك

لا شكر على واجب أخي الكريم @abouelhassan

[إبراهيم ابوليله]

اخى محمد

بارك الله فيك

مشكرا على الاهتمام

فى انتظار مشاركات اخرى

تفى بالغرض

تقبل تحياتى

 

[محمد حسن المحمد]

4 دقائق مضت, إبراهيم ابوليله said:

اخى محمد

بارك الله فيك

مشكرا على الاهتمام

فى انظار مشاركات اخرى

تفى بالغرض

تقبل تحاتى

 

وبارك بكم أخي الغالي @إبراهيم ابوليله أرجو أن يكون ما قدمت جزءاً من الحل حيث وجدته من خلال البحث..

تقبل تحياتي العطرة.