Excel VBA Macro to copy a range of file of files from one folder to another

djgenesis13

New Member
Joined
Apr 24, 2014
Messages
22
Hello,

I have been searching the forum for this and I can not find anything that does the job. The case is rather simple though.

I have a folder full of pictures (about 10000). I also have an excel file where in one sheet I have some filenames (without path) in a range of cells - not in one column only, the filenames are in a continuous range of cells and specifically in range AZ:BU (22 columns). This range has also got some empty cells and a header row. an exaple of a cell value is
"Baby_Monitor_with_Two_Way_Audio_Main.jpg".

<tbody>
</tbody>
I want to search a specific folder in my pc, find only the files in the range mentioned above and copy them to another specific folder. I have tried a sub found in the forum but I just keep getting errors '76' path not found

Sub Copy_Files()
oldpath = "C:\oldfolder\"
newpath = "C:\newfolder\"
For Each r In Range("az2", Range("bu" & Rows.Count).End(xlUp))
fn = Dir(oldpath & r)
If fn <> "" Then
FileCopy oldpath & r, newpath & r
End If
Next
End Sub

Thanks in advance
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Try this.

Code:
Sub CopyFilesNew()
Dim rValues As Range
Dim c As Range
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim sOldPath As String
Dim sNewPath As String
sOldPath = "C:\oldfolder\"
sNewPath = "C:\newfolder\"


Set rValues = Range("az2", Range("bu" & Rows.Count).End(xlUp))
For Each c In rValues.Cells
    If c.Value <> "" Then
        If fso.FileExists(sOldPath & c.Value) Then
            fso.CopyFile sOldPath & c.Value, sNewPath & c.Value
        End If
        
    End If
Next


End Sub
 
Upvote 0
Hello,

I tried it but it copies only some of them not all of them. Less than 20% to be exact. Yes the range has many blank cells in most of the columns.
 
Upvote 0
Doesn't sound like an issue with the code but an issue with file names recorded on the worksheet. Try running this code. It will highlight any cells that have a file name that doesn't exist in that path then you can troubleshoot those. I've also added trim to remove any leading or trailing spaces.

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> CopyFilesNew()<br>    <SPAN style="color:#00007F">Dim</SPAN> rValues <SPAN style="color:#00007F">As</SPAN> Range<br>    <SPAN style="color:#00007F">Dim</SPAN> c <SPAN style="color:#00007F">As</SPAN> Range<br>    <SPAN style="color:#00007F">Dim</SPAN> fso <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Object</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> fso = CreateObject("Scripting.FileSystemObject")<br>    <SPAN style="color:#00007F">Dim</SPAN> sOldPath <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> sNewPath <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>    sOldPath = "C:\oldfolder\"<br>    sNewPath = "C:\newfolder\"<br>    <SPAN style="color:#00007F">Set</SPAN> rValues = Range("az2", Range("bu" & Rows.Count).End(xlUp))<br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> c <SPAN style="color:#00007F">In</SPAN> rValues.Cells<br>        <SPAN style="color:#00007F">If</SPAN> c.Value <> "" <SPAN style="color:#00007F">Then</SPAN><br>            <SPAN style="color:#00007F">If</SPAN> fso.FileExists(sOldPath & Trim(c.Value)) <SPAN style="color:#00007F">Then</SPAN><br>                fso.CopyFile sOldPath & Trim(c.Value), sNewPath & Trim(c.Value)<br>            <SPAN style="color:#00007F">Else</SPAN><br>                c.Interior.Color = vbRed<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>
 
Upvote 0
It just returned 2 red cells...

I tried changing

Set rValues = Range("az2", Range("bu" & Rows.Count).End(xlUp))

to

Set rValues = Range("AZ2", Range("AZ" & Rows.Count).End(xlUp))

and it worked. how can I expand this to all of the collumns?
 
Upvote 0
Try this.

Code:
Option Explicit
Sub CopyFilesNew()
    Dim rValues As Range
    Dim c As Range
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim sOldPath As String
    Dim sNewPath As String
    sOldPath = "C:\oldfolder\"
    sNewPath = "C:\newfolder\"
    Set rValues = Range("az2", GetLastCell(Range("AZ:BU"), 3))
    For Each c In rValues.Cells
        If c.Value <> "" Then
            If fso.FileExists(sOldPath & Trim(c.Value)) Then
                fso.CopyFile sOldPath & Trim(c.Value), sNewPath & Trim(c.Value)
            Else
                c.Interior.Color = vbRed
            End If


        End If
    Next
End Sub




Public Function GetLastCell(InRange As Range, SearchOrder As XlSearchOrder, _
                            Optional ProhibitEmptyFormula As Boolean = False) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetLastCell
' By Chip Pearson, chip@cpearson.com, www.cpearson.com
'
' This returns the last used cell in a worksheet or range. If InRange
' is a single cell, the last cell of the entire worksheet if found. If
' InRange contains two or more cells, the last cell in that range is
' returned.
' If SearchOrder is xlByRows (= 1), the last cell is the last
' (right-most) non-blank cell on the last row of data in the
' worksheet's UsedRange. If SearchOrder is xlByColumns
' (= 2), the last cell is the last (bottom-most) non-blank cell in the
' last (right-most) column of the worksheet's UsedRange. If SearchOrder
' is xlByColumns + xlByRows (= 3), the last cell is the intersection of
' the last row and the last column. Note that this cell may not contain
' any value.
' If SearchOrder is anything other than xlByRows, xlByColumns, or
' xlByRows+xlByColumns, an error 5 is raised.
'
' ProhibitEmptyFormula indicates how to handle the case in which the
' last cell is a formula that evaluates to an empty string. If this setting
' is omitted for False, the last cell is allowed to be a formula that
' evaluates to an empty string. If this setting is True, the last cell
' must be either a static value or a formula that evaluates to a non-empty
' string. The default is False, allowing the last cell to be a formula
' that evaluates to an empty string.
'''''''''''''''''''''''''
' Example:
'       a   b   c
'               d   e
'       f   g
'
' If SearchOrder is xlByRows, the last cell is 'g'. If SearchOrder is
' xlByColumns, the last cell is 'e'. If SearchOrder is xlByRows+xlByColumns,
' the last cell is the intersection of the row containing 'g' and the column
' containing 'e'. This cell has no value in this example.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim WS As Worksheet
    Dim R As Range
    Dim LastCell As Range
    Dim LastR As Range
    Dim LastC As Range


    Dim LookIn As XlFindLookIn
    Dim RR As Range


    Set WS = InRange.Worksheet


    If ProhibitEmptyFormula = False Then
        LookIn = xlFormulas
    Else
        LookIn = xlValues
    End If


    Select Case SearchOrder
        Case XlSearchOrder.xlByColumns, XlSearchOrder.xlByRows, _
             XlSearchOrder.xlByColumns + XlSearchOrder.xlByRows
            ' OK
        Case Else
            Err.Raise 5
            Exit Function
    End Select


    With WS
        If InRange.Cells.Count = 1 Then
            Set RR = .UsedRange
        Else
            Set RR = InRange
        End If
        Set R = RR(RR.Cells.Count)


        If SearchOrder = xlByColumns Then
            Set LastCell = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                   LookAt:=xlPart, SearchOrder:=xlByColumns, _
                                   SearchDirection:=xlPrevious, MatchCase:=False)
        ElseIf SearchOrder = xlByRows Then
            Set LastCell = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                   LookAt:=xlPart, SearchOrder:=xlByRows, _
                                   SearchDirection:=xlPrevious, MatchCase:=False)
        ElseIf SearchOrder = xlByColumns + xlByRows Then
            Set LastC = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                LookAt:=xlPart, SearchOrder:=xlByColumns, _
                                SearchDirection:=xlPrevious, MatchCase:=False)
            Set LastR = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                                LookAt:=xlPart, SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, MatchCase:=False)
            Set LastCell = Application.Intersect(LastR.EntireRow, LastC.EntireColumn)
        Else
            Err.Raise 5
            Exit Function
        End If
    End With


    Set GetLastCell = LastCell


End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' END CODE GetLastCell
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
Upvote 0
it says it has a syntax error (letters are red)

Case XlSearchOrder.xlByColumns, XlSearchOrder.xlByRows, _
XlSearchOrder.xlByColumns XlSearchOrder.xlByRows
' OK
 
Upvote 0

Forum statistics

Threads
1,213,504
Messages
6,114,020
Members
448,543
Latest member
MartinLarkin

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