#1
|
|||
|
|||
Copy files based on a excel value
In a excel Column A is File Names & Column B is Status
I want to copy a files through browse option to select a source folder from where to copy and then through browse option to select a target folder to be pasted here(based on excel file names match cases). Column A is File Names Column B is Status (If the file is available then update as Copied, If N/A then update as Does not Exists) In source Folder each file name has three different formats( 123.docx , 123.rtf , 123.pdf) When 123 file name has matched then copied all the formats to the target folder & If the same file was already available in the target folder then ask for confirmation as "File Already exists, do you want replace (Yes or No). I had a code but which is not working effective only one format is copying and please anyone ammend the above changes to the below code. If anyone helps me in this regards am very thankful..... Please find the base code below & Attachment: Code:
Sub CopyFiles1() '' Code Dim iRow As Integer ' ROW COUNTER. Dim SourcePath As String Dim DestinationPath As String Dim sFileType As String Dim bContinue As Boolean bContinue = True iRow = 2 ' THE SOURCE AND DESTINATION FOLDER WITH PATH. SourcePath = InputBox("PLEASE ENTER PATH", "SOURCE PATH") & "\" DestinationPath = InputBox("PLEASE ENTER PATH", "DESTINATION PATH") & "\" sFileType = ".DOCX" sFileType = ".RTF" sFileType = ".PDF" ' LOOP THROUGH COLUMN "A" TO PICK THE FILES. While bContinue If Len(Range("A" & 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(SourcePath & Range("A" & CStr(iRow)).Value & sFileType)) = 0 Then Range("B" & CStr(iRow)).Value = "Does Not Exists" Range("B" & CStr(iRow)).Font.Bold = True Else Range("B" & CStr(iRow)).Value = "Copied" Range("B" & CStr(iRow)).Font.Bold = False If Trim(DestinationPath) <> "" Then Dim objFSO Set objFSO = CreateObject("scripting.filesystemobject") ' CHECK IF DESTINATION FOLDER EXISTS. If objFSO.FolderExists(DestinationPath) = False Then MsgBox DestinationPath & " 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:=SourcePath & Range("A" & CStr(iRow)).Value & _ sFileType, Destination:=DestinationPath ' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES. 'objFSO.MoveFile Source:=sSourcePath & Range("B" & CStr(iRow)).Value & _ sFileType, Destination:=sDestinationPath '***** End If End If End If iRow = iRow + 1 ' INCREMENT ROW COUNTER. Wend Set objFSO = Nothing End Sub |
#2
|
||||
|
||||
Have try with these few changes; at least it should get you to the next step since it never asked me "File Already exists, do you want replace (Yes or No)", maybe it's yet to be implemented:
Code:
Option Explicit Sub CopyFiles1() ''Code Dim iRow As Integer ' ROW COUNTER. Dim SourcePath As String Dim DestinationPath As String Dim sFileType As Variant '<- changed Dim bContinue As Boolean Dim x As Long '<- added bContinue = True iRow = 2 ' THE SOURCE AND DESTINATION FOLDER WITH PATH. SourcePath = InputBox("PLEASE ENTER PATH", "SOURCE PATH") & "\" DestinationPath = InputBox("PLEASE ENTER PATH", "DESTINATION PATH") & "\" sFileType = Array(".rtf", ".docx", ".pdf") '<- changed 'sFileType = ".docx" 'sFileType = ".rtf" ' LOOP THROUGH COLUMN "A" TO PICK THE FILES. While bContinue If Len(Range("A" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK. MsgBox "Process executed" ' DONE. bContinue = False Else ' CHECK IF FILES EXISTS. For x = LBound(sFileType) To UBound(sFileType) '<- added If Len(Dir(SourcePath & Range("A" & CStr(iRow)).Value & sFileType(x))) = 0 Then Range("B" & CStr(iRow)).Value = "Does Not Exists" Range("B" & CStr(iRow)).Font.Bold = True Else Range("B" & CStr(iRow)).Value = "Copied" Range("B" & CStr(iRow)).Font.Bold = False If Trim(DestinationPath) <> "" Then Dim objFSO Set objFSO = CreateObject("scripting.filesystemobject") ' CHECK IF DESTINATION FOLDER EXISTS. If objFSO.FolderExists(DestinationPath) = False Then MsgBox DestinationPath & " 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:=SourcePath & Range("A" & CStr(iRow)).Value & sFileType(x), Destination:=DestinationPath '<- changed ' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES. 'objFSO.MoveFile Source:=sSourcePath & Range("B" & CStr(iRow)).Value & sFileType(x) , Destination:=sDestinationPath '***** End If End If Next x '<- added End If iRow = iRow + 1 ' INCREMENT ROW COUNTER. Wend Set objFSO = Nothing End Sub |
#3
|
|||
|
|||
Thanks, Its working like a charm...
You did my job easy and thanks for your help.... |
#4
|
||||
|
||||
Glad I was able to help .
|
Tags |
copy and paste |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Copy a files based on excel value | ranjan | Excel | 4 | 08-29-2021 11:32 AM |
Browse, search and copy files from one location to another based on the list given in excel sheet us | nmkhan3010 | Excel Programming | 2 | 09-07-2020 10:27 AM |
Might it be possible to emulate the worksheet-based structure of Excel files in MS Word? | Arabiflora | Word | 1 | 05-27-2016 11:50 PM |
a macro that can copy data from copy.xls to our current excel macro.xls based on criteria: | udhaya | Excel Programming | 1 | 11-12-2015 10:12 AM |
Can a macro rename Excel files based on a cellname? | chrisd2000 | Excel Programming | 1 | 06-23-2014 06:50 PM |