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.
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?
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
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
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.