Moving and listing folders/subfolders issue.

[RhodEvans]

Afternoon,

I have a piece of code that I found here: List Folders & Subfolders From Directory That looks in a folder and lists all the subfolders within.
I managed to bastardise it to copy the files and folders to an archive folder. However all does not seem to be well with it. It has the following issues.

• Seeminly at random, some of the files it moves are put in copies of their original subfolders (where I would like them), whereas others are simply copied into the main 'archive' folder
• It is only meant to copy files which have been created in the last month but it copies nothing over. So I have disabled the IF subrotine that does it by using the ' to turn it into a comment.
• The file count it copies is always greater than the quantity of files in the original folder (In a directory of 4106 files it copies 8169) could this have something to do with hidden files?

If anyone has the knowledge to point me in the right direction I would be very grateful, as I am drawing a blank.
The code can be found below:

Const BIF_RETURNONLYFSDIRS As Long = &H1 ''' For finding a folder to start document searching
Const BIF_DONTGOBELOWDOMAIN As Long = &H2 ''' Does not include network folders below the domain level in the tree view control
Const BIF_RETURNFSANCESTORS As Long = &H8 ''' Returns only file system ancestors.
Const BIF_BROWSEFORCOMPUTER As Long = &H1000 ''' Returns only computers.
Const BIF_BROWSEFORPRINTER As Long = &H2000 ''' Returns only printers.
Const BIF_BROWSEINCLUDEFILES As Long = &H4000 ''' Returns everything.
 
Const MAX_PATH As Long = 260
 
Type BROWSEINFO
    hOwner     As Long
    pidlRoot   As Long
    pszDisplayName As String
    lpszINSTRUCTIONS As String
    ulFlags    As Long
    lpfn       As Long
    lParam     As Long
    iImage     As Long
End Type
 
Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, ByVal pszBuffer As String) As Long
Declare Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As Long

Function BrowseFolder() As String
     
    Const szINSTRUCTIONS As String = "Choose the folder to use for this operation." & vbNullChar
     
    Dim uBrowseInfo As BROWSEINFO
    Dim szBuffer As String
    Dim lID    As Long
    Dim lRet   As Long
     
    With uBrowseInfo
        .hOwner = 0
        .pidlRoot = 0
        .pszDisplayName = String$(MAX_PATH, vbNullChar)
        .lpszINSTRUCTIONS = szINSTRUCTIONS
        .ulFlags = BIF_RETURNONLYFSDIRS
        .lpfn = 0
    End With
     
    szBuffer = String$(MAX_PATH, vbNullChar)
     
     ''' Show the browse dialog.
    lID = SHBrowseForFolderA(uBrowseInfo)
     
    If lID Then
         ''' Retrieve the path string.
        lRet = SHGetPathFromIDListA(lID, szBuffer)
        If lRet Then BrowseFolder = Left$(szBuffer, InStr(szBuffer, vbNullChar) - 1)
    End If
     
End Function

Public fileno As Integer
 Public topath As String
Option Explicit
 
Sub CreateList()
    
     fileno = 0
    Application.ScreenUpdating = False
    Workbooks.Add ' create a new workbook for the folder list
     ' add headers
    With Cells(1, 1)
        .Value = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Cells(3, 1).Value = "Folder Path:"
    Cells(3, 2).Value = "Folder Name:"
    Cells(3, 3).Value = "Size:"
    Cells(3, 4).Value = "Subfolders:"
    Cells(3, 5).Value = "Files:"
    Cells(3, 6).Value = "Short Name:"
    Cells(3, 7).Value = "Short Path:"
    Range("A3:G3").Font.Bold = True
    ListFolders BrowseFolder, True
    Application.ScreenUpdating = True
    MsgBox "You can find the " & fileno & " copied offender files in " & topath
End Sub

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
   On Error Resume Next
     ' lists information about the folders in SourceFolder
    Dim FSO    As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim r      As Long
    Dim fdate As Date
  
   
    

    
    topath = "S:\Bicester - Talisman House\Programmes\_Info\PBVP\Archive A-Z"
    
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
     ' display folder properties
    r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Cells(r, 1).Value = SourceFolder.Path
    Cells(r, 2).Value = SourceFolder.Name
    Cells(r, 3).Value = SourceFolder.Size
    Cells(r, 4).Value = SourceFolder.SubFolders.Count
    Cells(r, 5).Value = SourceFolder.Files.Count
    Cells(r, 6).Value = SourceFolder.ShortName
    Cells(r, 7).Value = SourceFolder.ShortPath
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
        fdate = Int(SubFolder.DateLastModified)
 '       Debug.Print fdate
        'If fdate >= 30 Then
        SubFolder.Copy topath
        
        
       ' End If
        fileno = fileno + 1
        Application.StatusBar = "Progress: " & fileno & " Moved"
            ListFolders SubFolder.Path, True
        Next SubFolder
        
        
        Set SubFolder = Nothing
    End If
    Columns("A:G").AutoFit
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
    Application.StatusBar = False
  ' MsgBox "You can find the " & fileno & " copied offender files in " & topath
End Sub

Once again your help and advice is always gratefully and enthusiastically received.

Rhod