PDA

View Full Version : [SOLVED] Copy and Move files to existing Sub-folders based on filename/Sub-folders's Name



JOEYSCLEE
08-16-2017, 09:13 PM
Hi, there
Would you please :help to advise VBA code for copying and moving files to existing Sub-folders based on Filename/Sub-folders's Name? The date of Filenames will be changed daily. Meanwhile, it's better to have path selection for selecting the source folder to copy those files and paste them to destination folder.

mana
08-17-2017, 04:50 AM
Option Explicit


Sub test()
Dim pFld As String, cFld As String, myFile As String

With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
pFld = .SelectedItems.Item(1) & "\"
Else
Exit Sub
End If
End With

myFile = Dir(pFld & "*.*")

Do While myFile <> ""
cFld = Mid(myFile, 1, InStrRev(myFile, " ") - 1)
Name pFld & myFile As pFld & cFld & "\" & myFile
myFile = Dir()
Loop

End Sub

JOEYSCLEE
08-18-2017, 12:33 AM
Thanks Mana!! It works great! Nevertheless, those files are located in another other drive (not same as Folder location). Could you please help to advise the code again?

JOEYSCLEE
08-18-2017, 02:14 AM
Thanks Mana!! It works great! Nevertheless, those files are located in another other drive (not same as Folder location). Could you please help to advise the code again?

mana
08-18-2017, 09:07 PM
Option Explicit

Sub test2()
Dim srcFld As String, dstFld As String, subFld As String, myFile As String

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\*****\*****"
.Title = "select source folder"
If .Show Then
srcFld = .SelectedItems.Item(1) & "\"
Else
Exit Sub
End If
End With

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "D:"
.Title = "select destination folder"
If .Show Then
dstFld = .SelectedItems.Item(1) & "\"
Else
Exit Sub
End If
End With

myFile = Dir(srcFld & "*.*")

Do While myFile <> ""
subFld = Mid(myFile, 1, InStrRev(myFile, " ") - 1)
Name srcFld & myFile As dstFld & subFld & "\" & myFile
myFile = Dir()
Loop

End Sub

JOEYSCLEE
08-19-2017, 11:51 PM
Thanks Mana!! Nevertheless, It has error message after running new code.




Option Explicit

Sub test2()
Dim srcFld As String, dstFld As String, subFld As String, myFile As String

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\*****\*****"
.Title = "select source folder"
If .Show Then
srcFld = .SelectedItems.Item(1) & "\"
Else
Exit Sub
End If
End With

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "D:"
.Title = "select destination folder"
If .Show Then
dstFld = .SelectedItems.Item(1) & "\"
Else
Exit Sub
End If
End With

myFile = Dir(srcFld & "*.*")

Do While myFile <> ""
subFld = Mid(myFile, 1, InStrRev(myFile, " ") - 1)
Name srcFld & myFile As dstFld & subFld & "\" & myFile
myFile = Dir()
Loop

End Sub

mana
08-20-2017, 12:47 AM
vOption Explicit

Sub test3()
Dim srcFld As String, dstFld As String, subFld As String, myFile As String
Dim n As Long

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\*****\*****"
.Title = "select source folder"
If .Show Then
srcFld = .SelectedItems.Item(1) & "\"
Else
Exit Sub
End If
End With

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "D:"
.Title = "select destination folder"
If .Show Then
dstFld = .SelectedItems.Item(1) & "\"
Else
Exit Sub
End If
End With

myFile = Dir(srcFld & "*.*")

Do While myFile <> ""
n = InStrRev(myFile, " ") - 1
If n > 0 Then
subFld = Mid(myFile, 1, n)
Name srcFld & myFile As dstFld & subFld & "\" & myFile
End If
myFile = Dir()
Loop

End Sub

JOEYSCLEE
08-20-2017, 01:50 AM
Run Time Error "53" after running the revised code.



vOption Explicit

Sub test3()
Dim srcFld As String, dstFld As String, subFld As String, myFile As String
Dim n As Long

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\*****\*****"
.Title = "select source folder"
If .Show Then
srcFld = .SelectedItems.Item(1) & "\"
Else
Exit Sub
End If
End With

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "D:"
.Title = "select destination folder"
If .Show Then
dstFld = .SelectedItems.Item(1) & "\"
Else
Exit Sub
End If
End With

myFile = Dir(srcFld & "*.*")

Do While myFile <> ""
n = InStrRev(myFile, " ") - 1
If n > 0 Then
subFld = Mid(myFile, 1, n)
Name srcFld & myFile As dstFld & subFld & "\" & myFile
End If
myFile = Dir()
Loop

End Sub

mana
08-20-2017, 03:26 AM
rule of flename


Sub-folders's Name & space & date & ,extension



Option Explicit

Sub test4()
Dim srcFld As String, dstFld As String, subFld As String, myFile As String
Dim fso As Object, f As Object
Dim n As Long

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\*****\*****"
.Title = "select source folder"
If .Show Then
srcFld = .SelectedItems.Item(1)
Else
Exit Sub
End If
End With

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "D:"
.Title = "select destination folder"
If .Show Then
dstFld = .SelectedItems.Item(1)
Else
Exit Sub
End If
End With

Set fso = CreateObject("Scripting.FileSystemObject")

For Each f In fso.GetFolder(srcFld).Files
myFile = f.Name
n = InStrRev(myFile, " ") - 1
If n > 1 Then
subFld = dstFld & "\" & Mid(myFile, 1, n)
If fso.FolderExists(subFld) Then
f.Move subFld & "\"
End If
End If
Next

End Sub

JOEYSCLEE
08-20-2017, 04:21 AM
Below code works great. Thank you very much!!:clap::clap::clap:


rule of flename


Sub-folders's Name & space & date & ,extension



Option Explicit

Sub test4()
Dim srcFld As String, dstFld As String, subFld As String, myFile As String
Dim fso As Object, f As Object
Dim n As Long

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\*****\*****"
.Title = "select source folder"
If .Show Then
srcFld = .SelectedItems.Item(1)
Else
Exit Sub
End If
End With

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "D:"
.Title = "select destination folder"
If .Show Then
dstFld = .SelectedItems.Item(1)
Else
Exit Sub
End If
End With

Set fso = CreateObject("Scripting.FileSystemObject")

For Each f In fso.GetFolder(srcFld).Files
myFile = f.Name
n = InStrRev(myFile, " ") - 1
If n > 1 Then
subFld = dstFld & "\" & Mid(myFile, 1, n)
If fso.FolderExists(subFld) Then
f.Move subFld & "\"
End If
End If
Next

End Sub