VBA Code for Dynamic Folder Creation and Deletion

[kippit]

Hi everyone,

I am trying to create a VBA Code where:
1) Every time you insert a text into a cell in column A, a new folder is created
2) Every time a cell in column A is deleted, the folder with the same name is also deleted

I copied a VBA code online that made it so that the first condition is true. However, after the code is run once and adds the initial list of folders, any subsequent additions to column A won't create new folders unless I delete the initial list of folders. I have tried changing the condition, "If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0", to try and work around this issue but to no avail.

Is there also VBA code that helps me to dynamically delete folders with the same name as my cell values or refreshes the folders I have created to be the same as the list of names in column A?

Apologies if any of what I said sounds confusing. I am not very experienced in VBA Coding. Thank you for the help.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Z As Long
    Dim xVal As String
    On Error Resume Next
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    For Z = 1 To Target.Count
        If Target(Z).Value > 0 Then
            Call MakeFolders
        End If
    Next
    Application.EnableEvents = True
End Sub

Sub MakeFolders()
Dim Rng As Range
Dim LastRow As Long
Dim LastColumn As Long
Dim maxRows As Integer
Dim r As Integer
Dim c As Integer
Set sht = Worksheets("Activity List Data")
Set StartCell = Range("A2")
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = 1
  sht.Range(StartCell, sht.Cells(LastRow, LastColumn)).Select
Set Rng = Selection
maxRows = Rng.Rows.Count
For c = 1 To 1
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
End Sub

 

[John_w]

I am trying to create a VBA Code where:
1) Every time you insert a text into a cell in column A, a new folder is created
2) Every time a cell in column A is deleted, the folder with the same name is also deleted

Is there also VBA code that helps me to dynamically delete folders with the same name as my cell values or refreshes the folders I have created to be the same as the list of names in column A?

I wrote the code below for your second request which encompasses the 2 items in your first request, i.e. to maintain synchronisation between the folder names in column A and the actual subfolders of
mainFolder (the folder of the active workbook). The code looks at column A starting at A2.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim mainFolder As String
    Dim Acells As Variant, lastRow As Long, i As Long
    Dim colAsubfolders As String
    Dim subfolders As Collection, subfolder As Variant
    
    mainFolder = ActiveWorkbook.Path & "\"
    If Right(mainFolder, 1) <> "\" Then mainFolder = mainFolder & "\"
    
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    
    With Me
    
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        If lastRow >= 2 Then
        
            'Get all cell values in column A starting at row 2
            Acells = .Range("A2:A" & lastRow).Value
            
            'Create subfolders which don't exist
            colAsubfolders = "|"
            For i = 1 To UBound(Acells)
                If Not IsEmpty(Acells(i, 1)) Then
                    CreateSubfolder mainFolder & Acells(i, 1)
                    colAsubfolders = colAsubfolders & Acells(i, 1) & "|"
                End If
            Next
            
        End If
        
        'Delete subfolders which aren't in column A cells
        Set subfolders = New Collection
        subfolder = Dir(mainFolder & "*.*", vbDirectory)
        While subfolder <> vbNullString
            If subfolder <> "." And subfolder <> ".." Then subfolders.Add subfolder
            subfolder = Dir
        Wend
        For Each subfolder In subfolders
            If InStr(1, colAsubfolders, "|" & subfolder & "|", vbTextCompare) = 0 Then DeleteSubfolder mainFolder & subfolder
        Next
    
    End With
    
End Sub


Private Sub CreateSubfolder(folderPath As String)
    If Dir(folderPath, vbDirectory) = vbNullString Then
        MkDir folderPath
    End If
End Sub


Private Sub DeleteSubfolder(folderPath As String)
    If Dir(folderPath, vbDirectory) <> vbNullString Then
        RmDir folderPath
    End If
End Sub

 

[kippit]

Thanks for the solution! If I were to change the directory of where the folders will be stored, how do i change it?