Using a shared drive scenario and assuming that you wanted the subfolder name as part of the filename, insert this into a module. Change the path to the baseFolder to suit your network path.

I did not check to see if the file exists. You might want to do that with the Dir() command and use Kill() to delete it if you want it replaced.

[vba]Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal _
lpExistingFileName As String, ByVal lpNewFileName As String, ByVal _
bFailIfExists As Long) As Long


Sub CopyMyFiles()
Dim baseFolder As String, fileNames() As String
Dim newFolder As String, subFolder As String, i As Integer

baseFolder = "x:\test\" 'Use trailing backslash

'Exit if baseFolder does not exist
If Dir(baseFolder, vbDirectory) = "" Then
MsgBox baseFolder & vbLf & "does not exist.", vbCritical, "Macro Ending"
Exit Sub
End If

'Pick Files to Copy
fileNames() = GetFile("*.xls", "Select File(s)")

'Exit if Cancel was pressed. No files selected. Otherwise, get the subfolder name part.
On Error GoTo ExitSub
subFolder = fileNames(1)
On Error GoTo 0

'Copy each file selected to the new sub folder.
For i = 1 To UBound(fileNames)
'Create a folder from the base and sub folder names
subFolder = fileNames(i)
newFolder = baseFolder & GetBaseNoExt(subFolder) & "\"
If Dir(newFolder) = "" Then MkDir newFolder
CopyFile fileNames(i), newFolder & GetBaseName(fileNames(i)), False
Next i

ExitSub:
End Sub

Function GetBaseNoExt(sFilenameWithExtension As String) As String
Dim baseName As String
baseName = GetBaseName(sFilenameWithExtension)
GetBaseNoExt = Left(baseName, InStrRev(baseName, ".") - 1)
End Function

Function GetBaseName(stFullName As String) As String
Dim stPathSep As String 'Path separator character
Dim iFNLength As Integer 'Length of stFullName
Dim i As Integer
stPathSep = Application.PathSeparator
iFNLength = Len(stFullName)
'Find last path separator character, If there Is one
For i = iFNLength To 1 Step -1
If Mid(stFullName, i, 1) = stPathSep Then Exit For
Next i
GetBaseName = Right(stFullName, iFNLength - i)
End Function

Function GetFile(Optional sInitialFilename As String, Optional sTitle As String = "Select")
With Application.FileDialog(msoFileDialogOpen)
Dim vFN() As String, iFC As Integer
.InitialFileName = sInitialFilename
.Title = sTitle
.ButtonName = "&Select"
.AllowMultiSelect = True
.Filters.Add "Excel Files", "*.xls", 1
If .Show = -1 Then
ReDim vFN(1 To .SelectedItems.Count)
For iFC = 1 To .SelectedItems.Count
vFN(iFC) = .SelectedItems(iFC)
Next iFC
End If
GetFile = vFN()
End With
End Function[/vba]