Hello and Help needed with folder creation

Hi Paul,

See the attached working example. I included a few extra file functions in case you might need them in the future.

Lewis

Sub CreateFolder()

  Const sARCHIVE_FOLDER_NAME = "ArchiveXXX"

  Dim sPath As String
  

  sPath = ActiveWorkbook.Path & "\"

  'Create the 'Archive' Folder (subdirectory)
  'The function called creates the directory if it doesn't exist
  If LjmDirectoryCreate(sPath, sARCHIVE_FOLDER_NAME) <> 0 Then
    MsgBox "Software Integrity Error.  Program terminating." & vbCrLf & _
    "Folder (sub-directory) '" & sARCHIVE_FOLDER_NAME & "' could NOT be created."
    Exit Sub
  End If

End Sub

Public Function LjmDirectoryCreate(sPath As String, sDirectory As String) As Integer
  'This checks to see if a directory exists.
  'If the directory DOES NOT EXIST, the directory is CREATED.
  'Return values are as follows:
  '  0 = success
  '  1 = source file not found


  Dim sPathAndFolder As String


  LjmDirectoryCreate = 0

  sDirectory = sDirectory

  sPathAndFolder = sPath & sDirectory

  'If directory does NOT EXIST, CREATE the directory
  If LJMFolderExists(sPathAndFolder) = False Then
  
    '''''''''''''''''''''''''''''''''''''''''
    'Create Directory
    '''''''''''''''''''''''''''''''''''''''''
    MkDir sPathAndFolder
    
    
    'Make sure the directory exists or was created correctly
    If LJMFolderExists(sPathAndFolder) = False Then
      LjmDirectoryCreate = 0
    End If

  End If

End Function

 
Public Function LJMFolderExists(sPathAndFullFileName As String) As Boolean
  'This returns TRUE if a folder exists and FALSE if a folder does NOT exist
  'This will return FALSE if the 'sPathAndFullFileName' is a file
  
  Dim iFileAttributes As Integer

  On Error Resume Next
  iFileAttributes = GetAttr(sPathAndFullFileName)
  iFileAttributes = iFileAttributes And vbDirectory
  On Error GoTo 0
     
  LJMFolderExists = False
  If iFileAttributes = vbDirectory Then
    LJMFolderExists = True
  End If
  
End Function

Public Function LJMFileExists(sPathAndFullFileName As String) As Boolean
  'This returns TRUE if a file exists and FALSE if a file does NOT exist
  
  Dim iError As Integer
  Dim iFileAttributes As Integer

  On Error Resume Next
  iFileAttributes = GetAttr(sPathAndFullFileName)
     
  'Check the internal error  return
  iError = Err.Number
  Select Case iError
    Case Is = 0
        iFileAttributes = iFileAttributes And vbDirectory
        If iFileAttributes = 0 Then
          LJMFileExists = True
        Else
          LJMFileExists = False
        End If
    Case Else
        LJMFileExists = False
  End Select

  On Error GoTo 0

End Function
Public Function LJMFileIsDirectory(sPathAndFullFileName As String) As Boolean
  'This returns TRUE if a file is a Directory and FALSE if a file does NOT exist or is a file
  
  Dim iError As Integer
  Dim iFileAttributes As Integer

  On Error Resume Next
  iFileAttributes = GetAttr(sPathAndFullFileName)
     
  'Check the internal error  return
  iError = Err.Number
  If iError = 0 Then
    iFileAttributes = iFileAttributes And vbDirectory
    If iFileAttributes <> 0 Then
      LJMFileIsDirectory = True
    End If
  End If
  
  On Error GoTo 0

End Function

Public Function LJMFileOrFolderExists(sPathAndFullFileName As String) As Boolean
  'This returns TRUE if a file or folder exists and FALSE if a file or folder does NOT exist
  
  Dim iError As Integer
  Dim iFileAttributes As Integer

  On Error Resume Next
  iFileAttributes = GetAttr(sPathAndFullFileName)
     
  'Check the internal error  return
  iError = Err.Number
  Select Case iError
    Case Is = 0
        LJMFileOrFolderExists = True
    Case Else
        LJMFileOrFolderExists = False
  End Select

  On Error GoTo 0

End Function

Thank you so much Lewis! - I'll have a play

All the best

Paul

Sorry Lewis - I'm struggling still.

Your code is too advanced for me - I'm not sure how it should link with my original code (if at all). Are you able to give any guidance?

Many thanks

Paul

Thanks Lewis - much appreciated!

I will try the new code this evening.

Best regards

Paul

Hi Lewis

Sorry to bother you again

Your code is working great in that the desired folder is being created but the actual files are copying into the "C:\Users\Paul\Briefing Pack Selector\Output\" folder rather than the newly reated folder within the "...\Output\" folder.

Do you have any ideas where I'm going wrong?

Many thanks (again)

Paul

You created a New Subfolder named 'sPathAndSubFolderName'.

Your previous copy was:

FileCopy sSourceFolder & sFileName, sDestinationFolder & sFileName

You now have to create a NEW destination folder name to copy to the new SubFolder.
For example (code excerpt not tested):

'Create new Destination Folder from the New SubFolder name (needs trailing "\")
sDestinationFolder = sPathAndSubFolderName & "\"

'If you want to copy all the files to the new SubFolder, now
'The Destination folder contains the name including the new SubFolder name.
 For a = 1 To iNumberOfFiles
    sFileName = Cells(a, 1)
    FileCopy sSourceFolder & sFileName, sDestinationFolder & sFileName
 Next a

Lewis

Hi Lewis

Your explanation makes sense but if I already have the code

sDestinationFolder = "C:\Users\Paul\Briefing Pack Selector\Output\"

How can I also have the code:

sDestinationFolder = sPathAndSubFolderName & "\"

This is the code I have in the project at present:

Option Explicit


Sub cmd_CopyPk1_By_Lewis()

  Dim a As Integer
  Dim iNumberOfFiles As Integer
  Dim b As String
  
  Dim sDestinationFolder As String
  Dim sFileName As String
  Dim sSourceFolder As String
  Dim sSubFolderName As String
  Dim sPathAndSubFolderName As String
  
  sSourceFolder = "C:\Users\Paul\Briefing Pack Selector\Pack Contents\"
  sDestinationFolder = "C:\Users\Paul\Briefing Pack Selector\Output\"
  
  Sheets("Briefing Pack 1").Select
  
  'Copy Source files to the 'Output Folder'
  iNumberOfFiles = Cells(Rows.Count, 1).End(xlUp).Row
  
  For a = 1 To iNumberOfFiles
    sFileName = Cells(a, 1)
    FileCopy sSourceFolder & sFileName, sDestinationFolder & sFileName
  Next a

 
  '**********************************************************
  'Option 1 - Create a New Subfolder if it is a complete name (path and file) in Cell 'C3'
  '**********************************************************
  
  'Get the Subfolder name  (including path)
  sPathAndSubFolderName = Sheets("Briefing Pack Selector").Range("C3").Text
  
  'Strip out leading and trailing spaces from the name
  sPathAndSubFolderName = Trim(sPathAndSubFolderName)
  
  'Make sure the name is NOT BLANK
  If Len(sPathAndSubFolderName) = 0 Then
    MsgBox "Terminating.  The contents of cell 'C3' is BLANK"
    'Exit (i.e. 'Exit Sub' or do some other kind of error processing)
  End If
  
  'Create the new SubFolder (if it doesn't already exist)
  If LJMFolderExists(sPathAndSubFolderName) = False Then
    MkDir sPathAndSubFolderName & "\"
  
    If LJMFolderExists(sPathAndSubFolderName) = False Then
      MsgBox "Error in creating Subfolder: " & vbCrLf & _
             "Name: " & sPathAndSubFolderName
    End If
  End If
  
  
  '**********************************************************
  'Option 2 - Create a New Subfolder if it is not a completed path (.e.g. 'Archive')
  'that is a subfolder of 'C:\Users\Paul\Briefing Pack Selector\Output\'
  '**********************************************************
  
  'Create the Subfolder name
  '
  'NOTE: I arbitrarily chose 'C4' for this file name - for example purposes only
  sSubFolderName = Sheets("Briefing Pack Selector").Range("C3").Text
  
  'Strip out leading and trailing spaces from the name
  sPathAndSubFolderName = Trim(sPathAndSubFolderName)
  
  'Make sure the name is NOT BLANK
  If Len(sSubFolderName) = 0 Then
    MsgBox "Terminating.  The contents of cell 'C3' is BLANK"
    'Exit (i.e. 'Exit Sub' or do some other kind of error processing)
  End If
  
  'Create the complete Sub Folder path and file name
  'NOTE: 'sDestinationFolder' MUST have a trailing '\' (as it does in your case)
  sPathAndSubFolderName = sDestinationFolder & sSubFolderName
  
  'Create the new SubFolder (if it doesn't already exist)
  If LJMFolderExists(sPathAndSubFolderName) = False Then
    MkDir sPathAndSubFolderName & "\"
  
    If LJMFolderExists(sPathAndSubFolderName) = False Then
      MsgBox "Error in creating Subfolder: " & vbCrLf & _
             "Name: " & sPathAndSubFolderName
    End If
  End If
  
  
  MsgBox "Files have been copied to output folder"
  
  
  Sheets("Briefing Pack Selector").Select
End Sub

 
Public Function LJMFolderExists(sPathAndFullFileName As String) As Boolean
  'This returns TRUE if a folder exists and FALSE if a folder does NOT exist
  'This will return FALSE if the 'sPathAndFullFileName' is a file
  
  Dim iFileAttributes As Integer

  On Error Resume Next
  iFileAttributes = GetAttr(sPathAndFullFileName)
  iFileAttributes = iFileAttributes And vbDirectory
  On Error GoTo 0
     
  LJMFolderExists = False
  If iFileAttributes = vbDirectory Then
    LJMFolderExists = True
  End If
  
End Function

Thanks again

Paul

All we did was create the New Sub Folder, we didn't copy any information into it.

To do that, we have to put the code in post #8 at the bottom of the code in post #9.

Lewis

Hi Lewis

You must be sick of me so this is my last question (and if I still can't get it then I'll burn my laptop, throw the ashes into the sea and hang my head in shame)

If I add the post #8 code to the bottom of the post #9 code (I guessing you mean at the end of the sub before the Function - as it errors there), the files still copy onto the output folder and not the created one. It looks to me like the code is saying where to put the files before the folder is created - is this correct.

Sorry!

Paul

Yes. Try this (untested), which copies the data to the subfolder in cell "C4".

Public Sub cmd_CopyPk2_By_Lewis()

  Dim a As Integer
  Dim iNumberOfFiles As Integer
  Dim b As String
  
  Dim sDestinationFolder As String
  Dim sFileName As String
  Dim sSourceFolder As String
  Dim sSubFolderName As String
  Dim sPathAndSubFolderName As String
  
  sSourceFolder = "C:\Users\Paul\Briefing Pack Selector\Pack Contents\"
  sDestinationFolder = "C:\Users\Paul\Briefing Pack Selector\Output\"
  
  'The following were debugging statement(s) used by Lewis (can be ignored or deleted)
#Const Lewis = False
#If Lewis Then
  sSourceFolder = ThisWorkbook.Path & "\"
  sDestinationFolder = ThisWorkbook.Path & "\"
#End If

  Sheets("Briefing Pack 1").Select
  
  'Copy Source files to the 'Output Folder'
  iNumberOfFiles = Cells(Rows.Count, 1).End(xlUp).Row
  
  'The following were debugging statement(s) used by Lewis (can be ignored or deleted)
#If Lewis Then
  iNumberOfFiles = 0 'START HERE
#End If

  For a = 1 To iNumberOfFiles
    sFileName = Cells(a, 1)
    FileCopy sSourceFolder & sFileName, sDestinationFolder & sFileName
  Next a
  
  '**********************************************************
  'Option 1 - Create a New Subfolder if it is a complete name (path and file) in Cell 'C3'
  '**********************************************************
  
  'Get the Subfolder name  (including path)
  sPathAndSubFolderName = Sheets("Briefing Pack Selector").Range("C3").Text
  
  'Strip out leading and trailing spaces from the name
  sPathAndSubFolderName = Trim(sPathAndSubFolderName)
  
  'Make sure the name is NOT BLANK
  If Len(sPathAndSubFolderName) = 0 Then
    MsgBox "Terminating.  The contents of cell 'C3' is BLANK"
    'Exit (i.e. 'Exit Sub' or do some other kind of error processing)
  End If
  
  'Create the new SubFolder (if it doesn't already exist)
  If LJMFolderExists(sPathAndSubFolderName) = False Then
    MkDir sPathAndSubFolderName
  
    If LJMFolderExists(sPathAndSubFolderName) = False Then
      MsgBox "Error in creating Subfolder: " & vbCrLf & _
             "Name: " & sPathAndSubFolderName
    End If
  End If
  
  
  '**********************************************************
  'Option 2 - Create a New Subfolder if it is not a completed path (.e.g. 'Archive')
  'that is a subfolder of 'C:\Users\Paul\Briefing Pack Selector\Output\'
  '**********************************************************
  
  'Create the Subfolder name
  '
  'NOTE: I arbitrarily chose 'C4' for this file name - for example purposes only
  sSubFolderName = Sheets("Briefing Pack Selector").Range("C4").Text
  
  'Strip out leading and trailing spaces from the name
  sPathAndSubFolderName = Trim(sPathAndSubFolderName)
  
  'Make sure the name is NOT BLANK
  If Len(sSubFolderName) = 0 Then
    MsgBox "Terminating.  The contents of cell 'C3' is BLANK"
    'Exit (i.e. 'Exit Sub' or do some other kind of error processing)
  End If
  
  'Create the complete Sub Folder path and file name
  'NOTE: 'sDestinationFolder' MUST have a trailing '\' (as it does in your case)
  sPathAndSubFolderName = sDestinationFolder & sSubFolderName
  
  'Create the new SubFolder (if it doesn't already exist)
  If LJMFolderExists(sPathAndSubFolderName) = False Then
    MkDir sPathAndSubFolderName
  
    If LJMFolderExists(sPathAndSubFolderName) = False Then
      MsgBox "Error in creating Subfolder: " & vbCrLf & _
             "Name: " & sPathAndSubFolderName
    End If
  End If
  
  MsgBox "Files have been copied to output folder"
  
  'Put the files into the SubFolder From 'C4'
  sSourceFolder = "C:\Users\Paul\Briefing Pack Selector\Pack Contents\"
  sDestinationFolder = sPathAndSubFolderName & "\"
    
  For a = 1 To iNumberOfFiles
    sFileName = Cells(a, 1)
    FileCopy sSourceFolder & sFileName, sDestinationFolder & sFileName
  Next a
  
  MsgBox "Files have been copied to the SubFolder. Folder Name:" & vbCrLf & _
         sDestinationFolder
  
  Sheets("Briefing Pack Selector").Select
End Sub

 
Public Function LJMFolderExists(sPathAndFullFileName As String) As Boolean
  'This returns TRUE if a folder exists and FALSE if a folder does NOT exist
  'This will return FALSE if the 'sPathAndFullFileName' is a file
  
  Dim iFileAttributes As Integer

  On Error Resume Next
  iFileAttributes = GetAttr(sPathAndFullFileName)
  iFileAttributes = iFileAttributes And vbDirectory
  On Error GoTo 0
     
  LJMFolderExists = False
  If iFileAttributes = vbDirectory Then
    LJMFolderExists = True
  End If
  
End Function

Thanks Lewis! We have a winner. The files are still copying to the "...\output" folder as well as the created one but I can live with that.

Your help has really been appreciated

Best regards

Paul