duncanator24
06-27-2012, 06:11 AM
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)
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
(I had to block out the network drive name, so that is why it is just xxx)
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