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)
Else
MkDir (source & “\” & Sourcefileslen)
FileCopy (source & “\” & sourcefiles), (source & “\” & Sourcefileslen & “\” & sourcefiles)
Kill (source & “\” & sourcefiles)
End If
Next
sourcefiles = Dir$
Loop
MsgBox “The selected files have been copied to the matching selected subfolders!”, vbInformation
Exit_Copy:
Exit Function
Err_Copy:
CopyFilesToFolders = True
MsgBox Error$
Resume Exit_Copy
End Function
