Moving files to folders

[Alpha1980]

Supposing I have 3 empty folders on my desktop named "1", "2" and "3" and another folder named "docs" containing 18 files - 9 .tifs and 9 .txts.

Using VBA in Excel, how could I move the files from "docs" into the folder who's name is contained within the filename?

For example, after running the macro, I would end up with:

Folder "1" contains john1.tif, john1.txt, paul1.tif, paul1.txt, mark1.tif and mark1.txt
Folder "2" contains matthew2.tif, matthew2.txt, luke2.tif, luke2.txt, peter2.tif and peter2.txt
Folder "3" contains james3.tif, james3.txt, william3.tif, william3.txt, robert3.tif and robert3.txt

Hope you can help. Thanks.

 

[Andrew Poulsom]

Try:

Option Explicit

Declare Function SHGetSpecialFolderLocation Lib "Shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Declare Function SHGetPathFromIDList Lib "Shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long

Public Type ****EMID
    cb As Long
    abID As Byte
End Type

Public Type ITEMIDLIST
    mkid As ****EMID
End Type

Public Const MAX_PATH As Integer = 260
Public Const CSIDL_DESKTOP = &H0 '// The Desktop - virtual folder

Public Function fGetSpecialFolder(CSIDL As Long) As String
    Dim sPath As String
    Dim IDL As ITEMIDLIST
    fGetSpecialFolder = ""
    If SHGetSpecialFolderLocation(0, CSIDL, IDL) = 0 Then
        sPath = Space$(MAX_PATH)
        If SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) Then
            fGetSpecialFolder = Left$(sPath, InStr(sPath, vbNullChar) - 1) & ""
        End If
    End If
End Function

Sub Test()
    Dim Desktop As String
    Dim DocsFolder As String
    Dim FName As String
    Dim NewFolder As String
    Desktop = fGetSpecialFolder(CSIDL_DESKTOP) & Application.PathSeparator
    DocsFolder = Desktop & "docs" & Application.PathSeparator
    FName = Dir(DocsFolder & "*.*")
    Do While FName <> ""
        NewFolder = Mid(FName, InStr(1, FName, ".") - 1, 1)
        Name DocsFolder & FName As Desktop & NewFolder & Application.PathSeparator & FName
        FName = Dir
    Loop
End Sub

 

[Alpha1980]

Thank you so much Andrew - that is fantastic.

There are 3 more things that would make it perfect.

1. Rather than have a specified "docs" folder, it would be good to be able to select the folder containing the files using Application.GetOpenFilename
2. The empty folders should be stored inside the folder containing the files.
3. Rather than have the folders named "1", "2" and "3", there should be 106 folders each named with a 3 character alphanumeric code. Specifically: 6B1, 5HG, 5C2, 5A9, 5JE, 5ET, 5PG, 5CC, 5HP, 6C2, 5HQ, 5NY, 5K5, 6B3, 5JX, 6B2, 5J6, 5K7, 6A8, 6B7, 5NP, 5NG, 6A4, 5C3, 6A7, 5MD, 5NE, 6C1, 5N7, 5N6, 5N5, 5PE, 5HX, 5NH, 5NW, 5C1, 6B5, 6A2, 5NM, 5H1, 5C9, 5K6, 5A4, 5MX, 5CN, 5NQ, 5AT, 5HY, 5NX, 5K8, 5LA, 5N2, 5J4, 5N1, 5PC, 5PA, 5N9, 5NL, 5NT, 6B8, 6A1, 6A5, 5C5, 6B9, 5AN, 5NF, 5EF, 5PH, 5NV, 5PD, 5EM, 5N8, 5J5, 6A3, 6C4, 5NA, 6A9, 5H8, 5F5, 5PF, 5NJ, 5N4, 5M2, 5D1, 5M1, 5PK, 5F7, 5PJ, 6A6, 5LH, 5MK, 6C3, 5C4, 5NR, 6B6, 5N3, 5M3, 5NC, 5J2, 5PM, 5NN, 5LC, 5NK, 5MV, 5PL, 6B4

I hope this is a straightforward alteration. If not, don't worry and thanks anyway.

 

[Kenneth Hobson]

You will need to explain (3) more. What files would go in what folders?

 

[Alpha1980]

You will need to explain (3) more. What files would go in what folders?

Of course - sorry about that.

Any files with a name that contains the name of a folder should go inside it.

For example:

Folder "5ET" contains john5ET.tif, john5ET.txt, paul5ET.tif, paul5ET.txt, mark5ET.tif and mark5ET.txt
Folder "5PG" contains matthew5PG.tif, matthew5PG.txt, luke5PG.tif, luke5PG.txt, peter5PG.tif and peter5PG.txt
Folder "5CC" contains james5CC.tif, james5CC.txt, william5CC.tif, william5CC.txt, robert5CC.tif and robert5CC.txt

 

[Kenneth Hobson]

Is the convention that subfolders have 3 characters each as in your examples or will there be exceptions? This case is easily addressed.

Browsing to select a folder is easily done as well. However, if you use v2003+ there are some other methods like FileDialog that are generally used.

 

[Alpha1980]

Is the convention that subfolders have 3 characters each as in your examples or will there be exceptions? This case is easily addressed.

Browsing to select a folder is easily done as well. However, if you use v2003+ there are some other methods like FileDialog that are generally used.

No exceptions and I do use v2003.

 

[Kenneth Hobson]

Try:

Option Base 0
Sub MoveMyFiles()
  Dim rootFolder As String, subfolder As String
  Dim FName As String, fnames(), f
  
  'Get root foldername
  rootFolder = ActiveWorkbook.Path
  rootFolder = Get_Folder(rootFolder, "Pick Folder")
  If Right(rootFolder, 1) <> "\" Then _
    rootFolder = rootFolder & "\"
  If Dir(rootFolder, vbDirectory) = "" Then Exit Sub
  
  'Get filenames
  fnames() = FindFiles(rootFolder, "*.*", False)
  
  'Move files
  For Each f In fnames()
    subfolder = rootFolder & Mid(f, InStrRev(f, ".") - 3, 3) & "\"
    If Dir(subfolder, vbDirectory) <> "" Then
      Name f As subfolder & Right(f, Len(f) - InStrRev(f, "\"))
    End If
  Next f
End Sub

Private Function Get_Folder(Optional rootFolder As String, _
  Optional HeaderMsg As String) As String
    
  If rootFolder = "" Then rootFolder = ActiveWorkbook.Path
  
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = rootFolder
        .Title = HeaderMsg
        If .Show = -1 Then
            Get_Folder = .SelectedItems(1)
        Else
            Get_Folder = ""
        End If
    End With
End Function

Function FindFiles(sRootFolder As String, sFiles As String, _
  Optional searchSubFolders As Boolean = True) As Variant
 
    Dim fs As Object
    Dim strFilename As String
    Dim i As Long, LastRow As Long
    Dim a() As Variant
 
    Set fs = Application.FileSearch
    With fs
        .LookIn = sRootFolder
        .FileName = sFiles 'set your filename or extension with wilcards if needed.
        .searchSubFolders = searchSubFolders
        LastRow = .FoundFiles.Count
        If .Execute() > 0 Then
            For i = 1 To LastRow
                strFilename = .FoundFiles(i)
                ReDim Preserve a(i - 1)
                a(i - 1) = strFilename
            Next i
        Else
            MsgBox "No files found", vbCritical
        End If
    End With
 
    FindFiles = a()
 
End Function