VBA Copy files

S

Shammas

New Member
Joined
Apr 7, 2019
Messages
5
Hi friends,

I'm using excel VBA for copying list of files from column, I prepared program to copy files to a specific destination (Below the program)
I need help to create program for copying files to a list of destination listed in column respective to list of files

Option Explicit
Sub CopyFiles()
Dim FSO
Dim iRow As Integer ' ROW COUNTER.
Dim sSFolder As String
Dim sDFolder As String
Dim sFileType As String

Dim bContinue As Boolean

bContinue = True
iRow = 2

' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSFolder = Sheets("Book1").Range("D5")
sDFolder = Sheets("Book1").Range("D6")

Set FSO = CreateObject("Scripting.FileSystemObject")

sFileType = ".pdf" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".

' LOOP THROUGH COLUMN "B" TO PICK THE FILES.
While bContinue

If Len(Range("B" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
MsgBox "Process executed" ' DONE.
bContinue = False
Else
' CHECK IF FILES EXISTS.

If Len(Dir(sSFolder & Range("B" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("C" & CStr(iRow)).Value = "Does Not Exists"
Range("C" & CStr(iRow)).Font.Bold = True
Else
Range("C" & CStr(iRow)).Value = "On Hand"
Range("C" & CStr(iRow)).Font.Bold = False

If Trim(sDFolder) <> "" Then
Dim objFSO
Set objFSO = CreateObject("scripting.filesystemobject")

' CHECK IF DESTINATION FOLDER EXISTS.
If objFSO.FolderExists(sDFolder) = False Then
MsgBox sDFolder & " Does Not Exists"
Exit Sub
End If

'*****
' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.

' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
objFSO.CopyFile Source:=sSFolder & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDFolder

' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
'objFSO.MoveFile Source:=sSFolder & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
'*****
End If
End If
End If

iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
Try this. Change red "D" for the column with the destination folder

Code: 
Option Explicit
Sub CopyFiles()
    Dim FSO
    Dim iRow As Integer ' ROW COUNTER.
    Dim sSFolder As String
    Dim sDFolder As String
    Dim sFileType As String
    
    Dim bContinue As Boolean
    
    bContinue = True
    iRow = 2
    
    ' THE SOURCE AND DESTINATION FOLDER WITH PATH.
    sSFolder = Sheets("Book1").Range("D5")
    sDFolder = Sheets("Book1").Range("D6")
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    sFileType = ".pdf" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
    
    ' LOOP THROUGH COLUMN "B" TO PICK THE FILES.
    While bContinue
    
        If Len(Range("B" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
            MsgBox "Process executed" ' DONE.
            bContinue = False
        Else
            ' CHECK IF FILES EXISTS.
            
            If Len(Dir(sSFolder & Range("B" & CStr(iRow)).Value & sFileType)) = 0 Then
                Range("C" & CStr(iRow)).Value = "Does Not Exists"
                Range("C" & CStr(iRow)).Font.Bold = True
            Else
                Range("C" & CStr(iRow)).Value = "On Hand"
                Range("C" & CStr(iRow)).Font.Bold = False
                
[COLOR=#0000cd]                sDFolder = Range("[/COLOR][B][COLOR=#ff0000]D[/COLOR][/B][COLOR=#0000cd]" & CStr(iRow)).Value[/COLOR]
                
                If Trim(sDFolder) <> "" Then
                    Dim objFSO
                    Set objFSO = CreateObject("scripting.filesystemobject")
                    
                    ' CHECK IF DESTINATION FOLDER EXISTS.
                    If objFSO.FolderExists(sDFolder) = False Then
                        MsgBox sDFolder & " Does Not Exists"
                        Exit Sub
                    End If
                    
                    '*****
                    ' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
                    ' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
                    ' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.
                    
                    ' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
                    objFSO.CopyFile Source:=sSFolder & Range("B" & CStr(iRow)).Value & _
                    sFileType, Destination:=sDFolder
                    
                    ' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
                    'objFSO.MoveFile Source:=sSFolder & Range("B" & CStr(iRow)).Value & _
                    sFileType, Destination:=sDestinationPath
                    '*****
                End If
            End If
        End If
        
        iRow = iRow + 1 ' INCREMENT ROW COUNTER.
    Wend
End Sub
 
Upvote 0
Thanks you for your replay,

But still the files are copying to the previous 1 destination, below is the structure of my excel file

Files name to copy Status Folders to copy
LRT-QAG-028898On HandC:\Users\smoopil\Desktop\excel\Test\BLC03\ACV\
LRT-QAG-029972On HandC:\Users\smoopil\Desktop\excel\Test\BLC03\PDS\
LRT-QAG-029975On HandC:\Users\smoopil\Desktop\excel\Test\BLC03\FSS\
LRT-QAG-029978On HandC:\Users\smoopil\Desktop\excel\Test\EC201\ACV\
LRT-QAG-029979On HandC:\Users\smoopil\Desktop\excel\Test\EC201\ACV\
LRT-QAG-029980On HandC:\Users\smoopil\Desktop\excel\Test\EC201\FSS\
LRT-QAG-029981On HandC:\Users\smoopil\Desktop\excel\Test\EDD01\ACV\
LRT-QAG-029982On HandC:\Users\smoopil\Desktop\excel\Test\EDD01\PDS\


Please help me

<colgroup><col><col><col></colgroup><tbody>
</tbody>
 
Upvote 0
Are you using the method below?

Code: 
' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
                    objFSO.CopyFile Source:=sSFolder & Range("B" & CStr(iRow)).Value & _
                    sFileType, Destination:=sDFolder

Did you add the line of code?

Code: 
[COLOR=#0000cd]sDFolder = Range("[/COLOR][B][COLOR=#ff0000]D[/COLOR][/B][COLOR=#0000cd]" & CStr(iRow)).Value[/COLOR]

How did you add it?
 
Upvote 0
I copied the same program in your first replay, and also I tried replacing my sDfolder line with the above, but still not working, below the updated program program

Option Explicit
Sub CopyFiles()
Dim FSO
Dim iRow As Integer ' ROW COUNTER.
Dim sSFolder As String
Dim sDFolder As String
Dim sFileType As String

Dim bContinue As Boolean

bContinue = True
iRow = 2

' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSFolder = Sheets("Book1").Range("D5")
sDFolder = Range("D" & CStr(iRow)).Value

Set FSO = CreateObject("Scripting.FileSystemObject")

sFileType = ".pdf" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".

' LOOP THROUGH COLUMN "B" TO PICK THE FILES.
While bContinue

If Len(Range("B" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
MsgBox "Process executed" ' DONE.
bContinue = False
Else
' CHECK IF FILES EXISTS.

If Len(Dir(sSFolder & Range("B" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("C" & CStr(iRow)).Value = "Does Not Exists"
Range("C" & CStr(iRow)).Font.Bold = True
Else
Range("C" & CStr(iRow)).Value = "On Hand"
Range("C" & CStr(iRow)).Font.Bold = False


If Trim(sDFolder) <> "" Then
Dim objFSO
Set objFSO = CreateObject("scripting.filesystemobject")

' CHECK IF DESTINATION FOLDER EXISTS.
If objFSO.FolderExists(sDFolder) = False Then
MsgBox sDFolder & " Does Not Exists"
Exit Sub
End If

'*****
' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.

' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
objFSO.CopyFile Source:=sSFolder & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDFolder

' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
'objFSO.MoveFile Source:=sSFolder & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
'*****
End If
End If
End If

iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub
 
Upvote 0
You have to put the line where I indicated you:


Code: 
Option Explicit
Sub CopyFiles()
    Dim FSO
    Dim iRow As Integer ' ROW COUNTER.
    Dim sSFolder As String
    Dim sDFolder As String
    Dim sFileType As String
    
    Dim bContinue As Boolean
    
    bContinue = True
    iRow = 2
    
    ' THE SOURCE AND DESTINATION FOLDER WITH PATH.
    sSFolder = Sheets("Book1").Range("D5")
    '[COLOR=#ff0000]sDFolder = Sheets("Book1").Range("D6")  'delete this line[/COLOR]
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    sFileType = ".pdf" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
    
    ' LOOP THROUGH COLUMN "B" TO PICK THE FILES.
    While bContinue
    
        If Len(Range("B" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
            MsgBox "Process executed" ' DONE.
            bContinue = False
        Else
            ' CHECK IF FILES EXISTS.
            
            If Len(Dir(sSFolder & Range("B" & CStr(iRow)).Value & sFileType)) = 0 Then
                Range("C" & CStr(iRow)).Value = "Does Not Exists"
                Range("C" & CStr(iRow)).Font.Bold = True
            Else
                Range("C" & CStr(iRow)).Value = "On Hand"
                Range("C" & CStr(iRow)).Font.Bold = False
                
[SIZE=3][B][COLOR=#0000cd]                sDFolder = Range("[/COLOR][COLOR=#ff0000]D[/COLOR][COLOR=#0000cd]" & CStr(iRow)).Value  '[/COLOR][/B][/SIZE][B]here goes the line[/B]
                
                If Trim(sDFolder) <> "" Then
                    Dim objFSO
                    Set objFSO = CreateObject("scripting.filesystemobject")
                    
                    ' CHECK IF DESTINATION FOLDER EXISTS.
                    If objFSO.FolderExists(sDFolder) = False Then
                        MsgBox sDFolder & " Does Not Exists"
                        Exit Sub
                    End If
                    
                    '*****
                    ' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
                    ' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
                    ' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.
                    
                    ' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
                    objFSO.CopyFile Source:=sSFolder & Range("B" & CStr(iRow)).Value & _
                    sFileType, Destination:=sDFolder
                    
                    ' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
                    'objFSO.MoveFile Source:=sSFolder & Range("B" & CStr(iRow)).Value & _
                    sFileType, Destination:=sDestinationPath
                    '*****
                End If
            End If
        End If
        
        iRow = iRow + 1 ' INCREMENT ROW COUNTER.
    Wend
End Sub
 
Upvote 0
You're welcome and thanks for the feedback
 
Upvote 0
Hi,

I was trying to make the source folder also to copy from a list but it is not working, do you have any solution please help me, the below are the new program i prepared

Option Explicit
Sub MoveFiles()
Dim FSO
Dim iRow As Integer ' ROW COUNTER.
Dim sSFolder As String
Dim sDFolder As String
Dim sFileType As String

Dim bContinue As Boolean

bContinue = True
iRow = 2


Set FSO = CreateObject("Scripting.FileSystemObject")



sFileType = ".pdf" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".




' LOOP THROUGH COLUMN "B" TO PICK THE FILES.
While bContinue

If Len(Range("B" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
MsgBox "Process executed" ' DONE.
bContinue = False
Else

' CHECK IF FILES EXISTS.

If Len(Dir(sSFolder & Range("B" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("C" & CStr(iRow)).Value = "Does Not Exists"
Range("C" & CStr(iRow)).Font.Bold = True
Else
Range("C" & CStr(iRow)).Value = "On Hand"
Range("C" & CStr(iRow)).Font.Bold = False

' THE SOURCE AND DESTINATION FOLDER WITH PATH.

sSFolder = Range("F" & CStr(iRow)).Value 'New change for picking files from different path folder'
sDFolder = Range("D" & CStr(iRow)).Value 'here goes the line


If Trim(sDFolder) <> "" Then
Dim objFSO
Set objFSO = CreateObject("scripting.filesystemobject")


' CHECK IF DESTINATION FOLDER EXISTS.
If objFSO.FolderExists(sDFolder) = False Then
MsgBox sDFolder & " DESTINATION Does Not Exists"
Exit Sub
End If

'*****
' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.

' METHOD 1) - USING "MoveFile" METHOD TO Move THE FILES.
objFSO.MoveFile Source:=sSFolder & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDFolder

' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
'objFSO.MoveFile Source:=sSFolder & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
'*****
End If
End If
End If

iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

JeffGrant
  • Question
Macro fails due to date format
Replies
8
Views
454
MARK858
MARK858
G
  • Solved
Copy excel to new folder path - break
Replies
3
Views
583
Joe4
Joe4
F
  • Solved
VBA to match list of files in windows folder and copy all to another folder
Replies
3
Views
1K
rollis13
rollis13
I
  • Question
Modify VBA script to count rows with data in multiple sheets
Replies
0
Views
76
irishjsk
I
H
  • Question
Copying Files From Folder to Another
Replies
0
Views
478
hetherton
H

Forum statistics

Threads
1,214,614
Messages
6,120,519
Members
448,968
Latest member
Ajax40

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top