DirectoryExportUpdated.vb

Sub ExportSelected_Click()

    Dim CWS As Worksheet
    Set CWS = ActiveSheet
    
    ' Fields whose values are used when generating the exported directory name
    Dim FieldNames
    FieldNames = Array("Quote Ref (YY-MMXX)", _
                                   "Customer/ End user", _
                                   "Project Name or description")

    ' Names of the subdirectories beneath the exported directory
    Dim SubDirNames
    SubDirNames = Array("1.0_Corresp", _
                        "1.1_RequestTenderDoc", _
                        "1.2_Calculation", _
                        "1.3_Quote", _
                        "1.4_Order")
    
    ' Check: selected cell cannot be empty
    If IsEmpty(Cells(ActiveCell.Row, ActiveCell.Column).value) Then
        MsgBox "Selected cell is empty."
        End ' Return from the subroutine
    End If
    
    ' Check: selected element cannot be a field title
    Dim FieldRows As New Collection
    Dim FieldColums As New Collection
    
    Dim k
    For k = LBound(FieldNames) To UBound(FieldNames)
        Set CurrentField = CWS.Cells.Find(what:=FieldNames(k), lookat:=xlWhole, LookIn:=xlValues)
        If Not CurrentField Is Nothing Then
            FieldRows.Add CurrentField.Row
            FieldColums.Add CurrentField.Column
        End If
    Next k
    
    If CollectionValueExists(FieldRows, ActiveCell.Row) Then
        MsgBox "Cannot select row with field names:" & vbCrLf & Join(FieldNames, vbCrLf) & vbCrLf & vbCrLf & _
                "Choose one of their data cell from the rows below."
        End
    End If
    
    If Not CollectionValueExists(FieldColums, ActiveCell.Column) Then
        MsgBox "Cannot select cells that do not belong to:" & vbCrLf & Join(FieldNames, vbCrLf) & vbCrLf & vbCrLf & _
                "Choose data cell corresponding to one of the listed fields."
        End
    End If
    
    Dim DirName As String
    Dim EmptyColumns As New Collection
    
    Dim i
    For i = 0 To UBound(FieldNames)
        
        Set CurrentField = CWS.Cells.Find(what:=FieldNames(i), lookat:=xlWhole, LookIn:=xlValues)
        
        If CurrentField Is Nothing Then
            
            EmptyColumns.Add CurrentField.Column ' field was not found
            
        Else
            
            If IsEmpty(Cells(ActiveCell.Row, CurrentField.Column).value) Then
                
                EmptyColumns.Add CurrentField.Column 'cell of the field was empty
                    
            Else
                
                DirName = DirName & Cells(ActiveCell.Row, CurrentField.Column).value
                    
                If i < UBound(FieldNames) Then
                    If i > 0 Then
                        DirName = DirName & "_"
                    Else
                        DirName = DirName & "_"
                    End If
                End If
                    
            End If
            
        End If
            
    Next i
    
    If EmptyColumns.Count > 0 Then
                    
        Dim FoundEmptyMessage As String
        
        FoundEmptyMessage = "Found " & EmptyColumns.Count & " empty cell(s) in selected row " & ActiveCell.Row & " and column(s):" & vbCrLf
        
        Dim EmptyColumnsItem As Variant
        
        For Each EmptyColumnsItem In EmptyColumns
            FoundEmptyMessage = FoundEmptyMessage & Split(Cells(1, EmptyColumnsItem).Address, "$")(1) & ", "
        Next
        
        MsgBox FoundEmptyMessage
                    
    Else
            
        Dim OutRootDir As String
        OutRootDir = "D:\OneDrive - Nuctech\Sales\Quotes\2022-test"
        OutDir = OutRootDir & Application.PathSeparator & Trim(DirName)
               
        CreateDirectory (OutDir)
                    
        Dim j
        For j = 0 To UBound(SubDirNames)
            CreateDirectory (OutDir & Application.PathSeparator & SubDirNames(j))
        Next j
            
        MsgBox "Created" & vbCrLf & DirName & vbCrLf & _
                "in" & vbCrLf & OutRootDir & vbCrLf & _
                "with subdirectories:" & vbCrLf & Join(SubDirNames, vbCrLf)
                    
    End If
    
End Sub

' Check to see if a value is in a collection
Public Function CollectionValueExists(ByRef target As Collection, value As Variant) As Boolean
    Dim index As Long
    For index = 1 To target.Count
        If target(index) = value Then
            CollectionValueExists = True
            Exit For
        End If
    Next index
End Function

Sub CreateDirectory(strPath As String)
    Dim elm As Variant
    Dim strCheckPath As String

    strCheckPath = ""
    For Each elm In Split(strPath, Application.PathSeparator)
        strCheckPath = strCheckPath & elm & Application.PathSeparator
        If Len(Dir(strCheckPath, vbDirectory)) = 0 And strCheckPath <> Application.PathSeparator Then MkDir strCheckPath
        On Error Resume Next
    Next
End Sub