I want to copy multiple excel files into different folders i.e
for that i using following code
But after running above code only 1.xlsx is copy to a folder.
I want to copy different excel files to different folder which path is given into coloum B in above picture.
Sub Button1_Click()
' Move any FolderA files (columnA) to dirs in ColumnB
' if they are not already flagged as having been moved in ColumnC.
Const colA = 1
Const colB = 2
Const colC = 3
Const FolderA = "C:\Users\SP\Desktop\Sam\"
Const srcSheet = "Sheet1"
Dim xlS As Excel.Worksheet
Dim xlW As Excel.Workbook
Dim RN As Long ' row number
Dim fName As String
Dim fPath As String
Set xlW = ActiveWorkbook
Set xlS = xlW.Sheets(srcSheet)
RN = 2
fName = Trim(xlS.Cells(RN, colA).Text)
' We'll run thru ColA until we hit a blank
On Error Resume Next ' expect problems if no target Dir
While fName <> ""
If Trim(xlS.Cells(RN, colC).Text) = "" Then
fPath = Trim(xlS.Cells(RN, colB).Text)
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
If Dir(fPath & fName) <> "" Then Kill fPath & fName
FileCopy FolderA & fName, fPath & fName
DoEvents
If Err.Number <> 0 Then
xlS.Cells(RN, colC).Value = "Failed: Check target Dir"
Err.Clear
Else
xlS.Cells(RN, colC).Value = Now()
End If
End If
' ready for next one
RN = RN + 1
fName = Trim(xlS.Cells(RN, colA).Text)
Wend
MsgBox "Done it!!"
End Sub
for that i using following code
But after running above code only 1.xlsx is copy to a folder.
I want to copy different excel files to different folder which path is given into coloum B in above picture.
Sub Button1_Click()
' Move any FolderA files (columnA) to dirs in ColumnB
' if they are not already flagged as having been moved in ColumnC.
Const colA = 1
Const colB = 2
Const colC = 3
Const FolderA = "C:\Users\SP\Desktop\Sam\"
Const srcSheet = "Sheet1"
Dim xlS As Excel.Worksheet
Dim xlW As Excel.Workbook
Dim RN As Long ' row number
Dim fName As String
Dim fPath As String
Set xlW = ActiveWorkbook
Set xlS = xlW.Sheets(srcSheet)
RN = 2
fName = Trim(xlS.Cells(RN, colA).Text)
' We'll run thru ColA until we hit a blank
On Error Resume Next ' expect problems if no target Dir
While fName <> ""
If Trim(xlS.Cells(RN, colC).Text) = "" Then
fPath = Trim(xlS.Cells(RN, colB).Text)
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
If Dir(fPath & fName) <> "" Then Kill fPath & fName
FileCopy FolderA & fName, fPath & fName
DoEvents
If Err.Number <> 0 Then
xlS.Cells(RN, colC).Value = "Failed: Check target Dir"
Err.Clear
Else
xlS.Cells(RN, colC).Value = Now()
End If
End If
' ready for next one
RN = RN + 1
fName = Trim(xlS.Cells(RN, colA).Text)
Wend
MsgBox "Done it!!"
End Sub