Then I believe this should do it for you. The function to permit browsing to
choose a folder doesn't permit multiple selections, so it'll be a one-folder
at a time operation, but at least you don't have to copy the file to each one
in the future. Also did away with echoing moved file names to the workbook.
It'll just sit there looking blank until all the work is done - still
presents the finished message.
As always, test at least once on a copy of the real thing - maybe make a
copy of one entire folder and make sure that it works without permanently
destroying something it shouldn't. You can just copy and paste over what you
had from before.
Sub MoveExceptions()
Const keyWord = "Exceptions"
Dim basePath As String
Dim newPath As String
Dim anyFile As String
Dim oldLoc As String
Dim newLoc As String
Dim filesMovedCount As Long
'this does not permit multiple folder
'selection, nor will it display files in the
'folder(s) as you work your way to the one
'you want - it will select the current file
'you are looking into when you click the [OK] button
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then
Exit Sub ' nothing chosen/user [Cancel]'d
Else
basePath = .SelectedItems(1) & "\"
End If
End With
newPath = basePath & "Exceptions\"
On Error Resume Next
anyFile = Dir(newPath & "*.*", vbHidden + vbSystem)
If Err <> 0 Or anyFile = "" Then
'must create the new path
Err.Clear
MkDir newPath
End If
On Error GoTo 0
anyFile = Dir$(basePath & "*.xls")
Do While anyFile <> ""
If anyFile <> ThisWorkbook.Name Then
'UCase makes the spelling case-insensitive
If InStr(UCase(anyFile), UCase(keyWord)) Then
newLoc = newPath & anyFile
oldLoc = basePath & anyFile
On Error Resume Next
Name oldLoc As newLoc
If Err <> 0 Then
Err.Clear
Else
filesMovedCount = filesMovedCount + 1
End If
On Error GoTo 0
End If
End If
anyFile = Dir$()
Loop
MsgBox filesMovedCount & " " & keyWord & " files moved."
End Sub
Dave said:
Thanks for that!
Could you possibly remove the section that prints the files that have been
moved etc. as this isn't required.
Also, how would it be possible to specify different folders to find the
excel files rather than them having to be in the directory with the macro
workbook.
Thanks again
Dave
JLatham said:
Put this code into a workbook's regular code area, save the workbook in the
same folder with the files to be moved, then run the macro. It will not only
do the moves but will report the names of the files moved in a worksheet
(current active one when you start the macro) and will give you a message
telling you how many files were moved when the process finishes.
Easy way to get the code where it needs to go: press [Alt]+[F11] to open the
VB Editor. Choose Insert | Module from the VBE editor and cut and paste the
code into that module. Close the VB Editor and have at it (after saving the
workbook to the proper folder) - the file must be saved to that initial
folder for it all to work.
Sub MoveExceptions()
Const keyWord = "Exceptions"
Dim basePath As String
Dim newPath As String
Dim anyFile As String
Dim oldLoc As String
Dim newLoc As String
Dim rOffset As Long
Dim baseCell As Range
Dim filesMovedCount As Long
Set baseCell = ActiveSheet.Range("A" & Rows.Count). _
End(xlUp).Offset(1, 0)
basePath = ThisWorkbook.FullName
basePath = Left(basePath, InStrRev(basePath, "\"))
newPath = basePath & "Exceptions\"
On Error Resume Next
anyFile = Dir(newPath & "*.*", vbHidden + vbSystem)
If Err <> 0 Or anyFile = "" Then
'must create the new path
Err.Clear
MkDir newPath
End If
On Error GoTo 0
anyFile = Dir$(basePath & "*.xls")
Do While anyFile <> ""
If anyFile <> ThisWorkbook.Name Then
'UCase makes the spelling case-insensitive
If InStr(UCase(anyFile), UCase(keyWord)) Then
newLoc = newPath & anyFile
oldLoc = basePath & anyFile
On Error Resume Next
Name oldLoc As newLoc
If Err <> 0 Then
Err.Clear
baseCell.Offset(rOffset, 0) = _
anyFile & " Not Moved: Destination File Exists Already"
Else
baseCell.Offset(rOffset, 0) = anyFile
filesMovedCount = filesMovedCount + 1
End If
rOffset = rOffset + 1
On Error GoTo 0
End If
End If
anyFile = Dir$()
Loop
MsgBox filesMovedCount & " " & keyWord & " files moved."
End Sub
:
Hi Everyone,
I'm looking for help with a macro to move some Worksheets from one folder to
another (i.e. cut & paste).
The destination folder will need to also be created by the Macro.
In english, the macro will need to:
* Search through ThisWorkbook.Path for files called SOMETHING -
Exceptions.xls e.g. Workbook 1 - Exceptions.xls, Smith - Exceptions.xls etc.
etc.
* Create a directory called "Exceptions" in ThisWorkbook.Path
* Move all the files found with the name above into this Exceptions folder,
leaving all other excel workbooks here with different names.
Any help is greatfully received.
Thanks!!
Dave
