Moving files from one folder to another

I have some files in Folder1, i want to move some file to Folder2, if folder2 does not exist i wants to create same.

Files to move is mentioned in col.A, Folder1 path is mentioned in col. b & Folder2 path is mentioned in col.c

I tried this code, but not working.

[VBA]
Sub Move_Files()
'This will move Excel files from FromPath to ToPath.
'Note: It will create the folder ToPath

Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
Dim b As Variant
Dim c As Variant
Dim r As Variant


Set FSO = CreateObject("scripting.filesystemobject")

For r = 10 To Range("A65536").End(xlUp).Row
FileExt = Range("A" & r).Value

For b = 10 To Range("b65536").End(xlUp).Row
FromPath = Range("B" & b).Value
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If

For c = 10 To Range("c65536").End(xlUp).Row
ToPath = Range("C" & c).Value
If Right(ToPath, 1) <> "\" Then
ToPath = ToPath & "\"
End If

FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
FSO.CreateFolder (ToPath)
'This will write File Name in Errors sheet if this does not exist

Sheets("Error").Select
Range("B65536").End(xlUp).Select
ActiveCell.Offset(1, 0).Activate
Application.CutCopyMode = False
ActiveCell.Value = FileExt
ActiveCell.Offset(1, 0).Activate
Sheets("Sheet1").Select
End If

FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
On Error Resume Next
Next b
Next c
Next r


End Sub

[/VBA]


Pl help

I have also attached excel file.

I recommend backing up your files before trying this macro or yours.

This could done a bit easier using DOS's Move. Either way, even this will fail under some scenarios.

[vba]Sub Move_Files()
Dim sCell As Range, eCell As Range
Dim sResult As String
Dim fromString As String, toString As String

For Each sCell In Sheets("Sheet1").Range("A10", _
Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
fromString = TrailSep(sCell.Offset(0, 1).Value) & sCell.Value
toString = TrailSep(sCell.Offset(0, 2).Value) & sCell.Value
sResult = MoveFile(fromString, toString)
Set eCell = Sheets("ERROR").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
eCell.Resize(1, 3).Value = Range(sCell, sCell.Offset(0, 2)).Value
eCell.Offset(0, 3).Value = sResult
Next sCell
End Sub

Function MoveFile(sFrom As String, sTo As String, Optional tfOverWrite As Boolean = True) As String
If Dir(sFrom) = "" Then
MoveFile = "From File Does Not Exist"
Exit Function
End If

If Dir(FolderPart(sFrom), vbDirectory) = "" Then
MoveFile = "From Folder Does Not Exist"
Exit Function
End If

If Dir(FolderPart(sFrom), vbDirectory) = "" Then
MoveFile = "From Folder Does Not Exist"
Exit Function
End If

CreateFolder FolderPart(sTo)
If Dir(FolderPart(sTo), vbDirectory) = "" Then
MoveFile = "To Folder Does Not Exist"
Exit Function
End If

If Dir(sTo) <> "" And tfOverWrite = False Then
MoveFile = "To File Exists: File Not Moved"
Exit Function
End If

If Dir(sTo) <> "" Then Kill sTo
If Dir(sFrom) <> "" Then Name sFrom As sTo

If Dir(sTo) <> "" Then
MoveFile = "File Was Moved"
Exit Function
End If

MoveFile = "File Was NOT Moved"
End Function

Sub CreateFolder(sPath As String)
Dim a() As String, s As String, subF
a() = Split(sPath, "\")
On Error Resume Next
s = ""
For Each subF In a()
s = s & subF & "\"
ChDrive Left(s, 1)
MkDir s
Next subF
End Sub

Function FolderPart(sPath As String) As String
FolderPart = Left(sPath, InStrRev(sPath, "\"))
End Function

Function FilenamePart(sFullname As String) As String
FilenamePart = Mid(sFullname, InStrRev(sFullname, "\") + 1)
End Function

Function TrailSep(str As String) As String
If Right(str, 1) = Application.PathSeparator Then
TrailSep = str
Else: TrailSep = str & Application.PathSeparator
End If
End Function
[/vba]

thanks

ya i know how to do with dos, earlier i used to do with same, but new boys dont know operating dos.

can give them batch file to play with

thanks once again:friends:

can u tell me where can i learn further handling with files in vba :dunno&

if u can explain me what u did wud be thankful:doh:

Would it be same for copying file.

i replaced Move to Copy but not working

sResult = MoveFile(fromString, toString)

to

sResult = CopyFile(fromString, toString)

any suggestion

It would have been better to start a new thread and add a link to this one since the solution is similar. Please mark this thread solved.

You can not just rename a Sub and expect it to do something other than what it was designed to do. Luckily, there is only one line that has to be recoded to make it work. However, I also changed a few lines to make it clear that the file was copied rather than moved. See the last VBA code below for the FileCopy() routine.

The line in the other to rename the file uses the class FileSystem and method Name(). In this code, I used the method FileCopy().

Press F2 in the VBE, Visual Basic Editor, to browse. Select the VBA library from the dropdown list or All Libraries. Then choose the FileSystem class. Of course you could just type FileSystem. and the . would make the members show if you have the VBE option set to Auto List Members. If the . does not work, select Tools > Options in VBE, and check that option.

To explore other methods, search this forum for FSO, File System Object. To explore that object's methods, see the following code for examples and links to help for FSO. I used early binding so you will have to add the reference from VBE's Tools > References as explained in the code comments. The API guide link is another method but more involved. The FSO method does many of the same methods as the API routines but it is easier to use since early binding the FSO object allows intellisense to work in the VBE for that object.
[vba]'http://allapi.mentalis.org/agnet/apiguide.shtml
'script56.chm, http://tinyurl.com/5ts6r8
Sub MoveFolder()
Rem Needs Reference: MicroSoft Script Runtime, scrrun.dll
Rem Instructions: http://support.microsoft.com/default...b;en-us;186118
Dim FSO As Scripting.FileSystemObject
Dim sSource As String
Dim sDest As String

Set FSO = New Scripting.FileSystemObject

sSource = Range("A1").Value
sDest = Range("A2").Value
FSO.MoveFolder sSource, sDest
End Sub
Sub CopyFolder()
Rem Needs Reference: MicroSoft Script Runtime, scrrun.dll
Rem Instructions: http://support.microsoft.com/default...b;en-us;186118
Dim FSO As Scripting.FileSystemObject
Dim sSource As String
Dim sDest As String

Set FSO = New Scripting.FileSystemObject

sSource = Range("A1").Value
sDest = Range("A2").Value

FSO.CopyFolder sSource, sDest, True
End Sub[/vba]
Here is your CopyFile Sub with the same supporting Subs as shown earlier.
[vba]Option Explicit
Sub Copy_Files()
Dim sCell As Range, eCell As Range
Dim sResult As String
Dim fromString As String, toString As String

For Each sCell In Sheets("Sheet1").Range("A10", _
Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
fromString = TrailSep(sCell.Offset(0, 1).Value) & sCell.Value
toString = TrailSep(sCell.Offset(0, 2).Value) & sCell.Value
sResult = CopyFile(fromString, toString)
Set eCell = Sheets("ERROR").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
eCell.Resize(1, 3).Value = Range(sCell, sCell.Offset(0, 2)).Value
eCell.Offset(0, 3).Value = sResult
Next sCell
End Sub
Function CopyFile(sFrom As String, sTo As String, Optional tfOverWrite As Boolean = True) As String
If Dir(sFrom) = "" Then
CopyFile = "From File Does Not Exist"
Exit Function
End If

If Dir(FolderPart(sFrom), vbDirectory) = "" Then
CopyFile = "From Folder Does Not Exist"
Exit Function
End If

If Dir(FolderPart(sFrom), vbDirectory) = "" Then
CopyFile = "From Folder Does Not Exist"
Exit Function
End If

CreateFolder FolderPart(sTo)
If Dir(FolderPart(sTo), vbDirectory) = "" Then
CopyFile = "To Folder Does Not Exist"
Exit Function
End If

If Dir(sTo) <> "" And tfOverWrite = False Then
CopyFile = "To File Exists: File Not Copied"
Exit Function
End If

If Dir(sTo) <> "" Then Kill sTo
If Dir(sFrom) <> "" Then FileCopy sFrom, sTo

If Dir(sTo) <> "" Then
CopyFile = "File Was Copied"
Exit Function
End If
CopyFile = "File Was NOT Copied"
End Function
Sub CreateFolder(sPath As String)
Dim a() As String, s As String, subF
a() = Split(sPath, "\")
On Error Resume Next
s = ""
For Each subF In a()
s = s & subF & "\"
ChDrive Left(s, 1)
MkDir s
Next subF
End Sub
Function FolderPart(sPath As String) As String
FolderPart = Left(sPath, InStrRev(sPath, "\"))
End Function
Function FilenamePart(sFullname As String) As String
FilenamePart = Mid(sFullname, InStrRev(sFullname, "\") + 1)
End Function
Function TrailSep(str As String) As String
If Right(str, 1) = Application.PathSeparator Then
TrailSep = str
Else: TrailSep = str & Application.PathSeparator
End If
End Function
[/vba]

Thanks:clap::friends::006: