Need for Speed

[duncanator24]

Hey, So I am trying to make my code run faster. Currently it takes about 5-10 minutes to process everything and I would like to make it run in under a minute if possible. Essentially the purpose of this code is to read an excel sheet for values and then find files with those names within a specific folder. Then it will move those files to another folder. In the process it is creating folders with the name of the file groups. The one thing I have done is to make the code stop at the end of a column once it has reached a blank cell. This is what keeps it from running for hours but I would definitely like it to operate faster. Any suggestions on this code and just speeding up a VBA code in general would be appreciated! Thanks.
(I had to block out the network drive name, so that is why it is just xxx)

[vba]Sub MoveOriginalFiles()

Dim FSO, sourceFolder, currentFile, filesInSourceFolder
Dim strSourceFolderPath As String
Dim strDestinationFolderPath As String
Dim ShipName As String
Dim IncludeAll As String
Set FSO = CreateObject("Scripting.FileSystemObject")

For ColIndex = 2 To 256 ' Search the row to find name of class

If ActiveSheet.Cells(5, ColIndex) = "" Then
Exit Sub ' Exit the Macro at the end of the list
End If

For RowIndex = 6 To 256 ' Search the column to find name of ship

If ActiveSheet.Cells(RowIndex, ColIndex) = "" Then
Exit For ' Exit the ship list at the bottom of the list and move on to next class
End If
'determine class and ship name based on the current postion on the chart
ClassName = ActiveSheet.Cells(5, ColIndex).Value
ShipName = ActiveSheet.Cells(RowIndex, ColIndex).Value
'set the source and destination paths
strSourceFolderPath = "\\xxx\xxx\xxx\xxx\" & ClassName
strDestinationFolderPath = "\\xxx\xxx\xxx\xxx\" & ClassName & "\" & "Archive" & "\" & ShipName
'check to see if the archive directory exists
ArchiveCheck = "\\xxx\xxx\xxx\xxx\" & ClassName & "\" & "Archive"
If Len(Dir(ArchiveCheck, vbDirectory)) = 0 Then
MkDir ArchiveCheck 'create the archive directory if it does not exist
End If

Set sourceFolder = FSO.GetFolder(strSourceFolderPath)
Set filesInSourceFolder = sourceFolder.Files

For Each currentFile In filesInSourceFolder 'Check every file in the folder
NumDigits = Len(ShipName) 'See how long the ship name is
IncludeAll = Left(currentFile.Name, NumDigits) 'Use only the length of the ship name
If IncludeAll = ShipName Then 'Check to see if the start of the filename matches the ship name
If Len(Dir(strDestinationFolderPath, vbDirectory)) = 0 Then 'Create the destination directory if it does not exist
MkDir strDestinationFolderPath
End If
currentFile.Copy (FSO.BuildPath(strDestinationFolderPath, currentFile.Name)) 'Move the files to the correct folder
currentFile.Delete
End If
Next
Next RowIndex

Next ColIndex
End Sub
[/vba]

[Kenneth Hobs]

Welcome to the forum!

Rather than Copy and Delete, why not just Move? To that end, examine the method that I used in the following thread and look at the way that I created the folder as well which may or may not help. http://www.vbaexpress.com/forum/showthread.php?t=42710

I don't see where you are activating cells that would cause a slow down. In any case, you could always try some of my speedup methods. http://vbaexpress.com/kb/getarticle.php?kb_id=1035

[duncanator24]

I remember having an issue with the move command back when I started, but I think it was a different thing causing that issue so it should work now. That will help the actual file processing part. But I think the part that is really slowing it down is reading the name of each file in the folder and then checking that name to the excel file. Is there a faster way to read the file names than using the FSO method that I used?

[Kenneth Hobs]

FSO is fine. You can have your cake and eat it too if you like. You defined fso as Variant though it is technically an Object. To speed it up more, use Early Binding rather than Late Binding. http://msdn.microsoft.com/en-us/libr...=VS.71%29.aspx

I noticed that you mixed in VBA methods with fso methods. I am not sure which is faster.

If you are just getting one folder of files, here is an example using Dir().

[vba]Sub DirFiles()
Dim FileName As String, FileSpec As String, FileFolder As String
Dim wb As Workbook

FileFolder = ThisWorkbook.Path & "\"
FileSpec = FileFolder & "*.xl*"

FileName = Dir(FileSpec)
If FileName = "" Then Exit Sub

' Loop until no more matching files are found
Do While FileName <> ""
If IsWorkbookOpen(FileName) = False Then
Set wb = Workbooks.Add(FileFolder & FileName)
DoEvents
wb.Close True
End If
FileName = Dir()
Loop

End Sub[/vba]
Another speedup is not to refer to the same Object several times. Use With to set the reference once. Here is an example With.
[vba]Sub MoveOriginalFiles()

Dim FSO As Object, sourceFolder As Object, currentFile As Object, filesInSourceFolder As Object
Dim strSourceFolderPath As String
Dim strDestinationFolderPath As String
Dim ShipName As String
Dim IncludeAll As String
Set FSO = CreateObject("Scripting.FileSystemObject")

For ColIndex = 2 To 256 ' Search the row to find name of class

If ActiveSheet.Cells(5, ColIndex) = "" Then
Exit Sub ' Exit the Macro at the end of the list
End If

For RowIndex = 6 To 256 ' Search the column to find name of ship

If ActiveSheet.Cells(RowIndex, ColIndex) = "" Then
Exit For ' Exit the ship list at the bottom of the list and move on to next class
End If
'determine class and ship name based on the current postion on the chart
ClassName = ActiveSheet.Cells(5, ColIndex).Value
ShipName = ActiveSheet.Cells(RowIndex, ColIndex).Value
'set the source and destination paths
strSourceFolderPath = "\\xxx\xxx\xxx\xxx\" & ClassName
strDestinationFolderPath = "\\xxx\xxx\xxx\xxx\" & ClassName & "\" & "Archive" & "\" & ShipName
'check to see if the archive directory exists
ArchiveCheck = "\\xxx\xxx\xxx\xxx\" & ClassName & "\" & "Archive"
If Len(Dir(ArchiveCheck, vbDirectory)) = 0 Then
MkDir ArchiveCheck 'create the archive directory if it does not exist
End If

Set sourceFolder = FSO.GetFolder(strSourceFolderPath)
Set filesInSourceFolder = sourceFolder.Files

For Each currentFile In filesInSourceFolder 'Check every file in the folder
With currentFile
NumDigits = Len(ShipName) 'See how long the ship name is
IncludeAll = Left(.Name, NumDigits) 'Use only the length of the ship name
If IncludeAll = ShipName Then 'Check to see if the start of the filename matches the ship name
If Len(Dir(strDestinationFolderPath, vbDirectory)) = 0 Then 'Create the destination directory if it does not exist
MkDir strDestinationFolderPath
End If
.Copy (FSO.BuildPath(strDestinationFolderPath, .Name)) 'Move the files to the correct folder
.Delete
End If
End With
Next
Next RowIndex

Next ColIndex
End Sub[/vba]

[snb]

Apparently you are not familiar with the fso movefolder method.
I think this is all you need.
If the folder doesn't exist, it will be created automatically.


[vba]Sub MoveOriginalFiles()

sn =activesheet.cells(1).currentregion

with CreateObject("Scripting.FileSystemObject")
for j=1 to ubound(sn)
.movefolder "\\xxx\xxx\xxx\xxx\" & sn(j,5) , \\xxx\xxx\xxx\xxx\" & sn(j,5) & "\" & "Archive" & "\" & sn(j,6)
next
end with
End Sub[/vba]