MS Access vba to match filename with folder name

By AlOffTech ·
I would need help with an MS Access vba function that would loop through a folder populated with Excel files then copy these files to a matching destination folder name (extension .xlsx removed). Any unmatched files would be copied to a new folder (in the source folder) with the name of the file (less extension) then killed in the source folder. The 1st loop works OK but then the 2nd loop is wrong. Here is the vba:

Public Function CopyFilesToMatchFolders()

On Error GoTo Exit_Copy

Dim sourcefiles As String
Dim Sourcefileslen
Dim SubFolder
Dim destination As String
Dim source As String

Dim FileSystem As Object

Set FileSystem = CreateObject("Scripting.FileSystemObject")

With Application.FileDialog(msoFileDialogFolderPicker)

.Title = "Select a folder that contains files to copy."

If .Show = -1 Then source = .SelectedItems(1)
If Len(source) = 0 Then Exit Function
.AllowMultiSelect = True

.Title = "Select a folder location to copy the files."

If .Show = -1 Then destination = .SelectedItems(1)

If Len(destination) = 0 Then Exit Function

End With

sourcefiles = Dir$(source & "\*.*")

Do While Len( sourcefiles) > 0

For Each SubFolder In FileSystem.GetFolder(destination).subfolders

Sourcefileslen = Left(sourcefiles, 7)
SubFolderlen = Right(SubFolder, 7)

If Sourcefileslen = SubFolderlen Then

FileCopy (source & "\" & sourcefiles), (SubFolder.Path & "\" & sourcefiles)

MkDir (source & "\" & Sourcefileslen)
FileCopy (source & "\" & sourcefiles), (source & "\" & Sourcefileslen & "\" & sourcefiles)
Kill (source & "\" & sourcefiles)

End If


sourcefiles = Dir$


MsgBox "The selected files have been copied to the matching selected subfolders!", vbInformation


Exit Function

CopyFilesToFolders = True
MsgBox Error$
Resume Exit_Copy

End Function

This conversation is currently closed to new comments.

Thread display: Collapse - | Expand +

All Answers

Share your knowledge

Related Discussions

Related Forums