Copy files from defined folders to a separate folder

[wayne9606]

I am big into Ancestry and I am trying to copy files used on a particular branch of a tree to a separate folder as a gift to that family member (The gift also includes their tree ). I use a relational database for storage of the tree and its multimedia report can be saved as a excel wb. I have managed to extract that info into a .xlsm file where I am trying to get the macro Copy_MediaV2() to work.

Multimedia List.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	FileName	SourcePath and FileName			C:\Users\Big W\OneDrive\Documents\Julies Folder\ImageCopy\								FileName
2	Arthur Ernest and Winifred Agnes Isaacson Gravesite.jpeg	C:\Users\Big W\OneDrive\Documents\MoveTest\Arthur Ernest and Winifred Agnes Isaacson Gravesite.jpeg
3	Arthur Ernest and Winifred Agnes Isaacson Headstone.jpeg	C:\Users\Big W\OneDrive\Documents\MoveTest\Arthur Ernest and Winifred Agnes Isaacson Headstone.jpeg
4	Mary Bennie Headstone and Robert Bennie Memorial.jpeg	C:\Users\Big W\OneDrive\Documents\MoveTest\Mary Bennie Headstone and Robert Bennie Memorial.jpeg
5	Robert McCullough Bennie.jpg	C:\Users\Big W\OneDrive\Documents\MoveTest2\Robert McCullough Bennie.jpg
6	a60ad9ad-8260-4cbe-928b-b6f1e04816e4.jpg	C:\Users\Big W\OneDrive\Documents\MoveTest\a60ad9ad-8260-4cbe-928b-b6f1e04816e4.jpg
7	George Isaacson and Sarah ****erton Marriage record.jpg	C:\Users\Big W\OneDrive\Documents\MoveTest2\George Isaacson and Sarah ****erton Marriage record.jpg
8	Charles Cuthbert Ryan WW1 Military Record NAA 1.pdf	C:\Users\Big W\OneDrive\Documents\MoveTest\Charles Cuthbert Ryan WW1 Military Record NAA 1.pdf
Working

Column A is the file name
and Column B is the Source Path and file name of the file I wish to copy.

E1 Contains the Destination Path (Would like this be be an open of explorer and select Destination Path)

Possible Errors
Source Folder does not exist
File does not exist in Source Path (advise in Column m & and by msg box)
File already exists in Destination Path (overwrite and advise in Column m and by msg box)
I have got myself into a complete dither in the past 24 hours. This morning I ran this again and somehow it has found a random image and converted it to a .dll and placed that in the destination as well as the other files.

The error messaging is out of sync with what is actually happening. The reporting in Column M is not as desired. As I said opening explorer to define the destination folder is also preferable. Thanks in advance and hopefully I have described the challenge as neatly as possible. Regards Wayne b

Sub Copy_MediaV2()
   Dim r As Long
    Dim SourcePath As String
    Dim dstPath As String
    Dim myFile As String
    Dim noFile As String
    Dim cFile As String
    'SourcePath = Range("d1")
    dstPath = Range("e1")
'Column M Report
noFolder = "No Source Folder Found"
noFile = "No File found in Source Folder"
fExists = "File already existed in destination and was overwritten"
'cFile = "File Copied to destination Folder"
   
 'On Error GoTo ErrHandler

    For r = 1 To 3000
        myFile = Range("A" & r)
        
        'FileCopy SourcePath & myFile, dstPath & myFile
        
        myFile = Dir(dstPath & Range("A" & r))
        SourcePath = Dir(Range("b" & r))  'added direct source path from Column b
        FileCopy SourcePath, myFile
        'FileCopy SourcePath & myFile, dstPath & myFile
        If Range("A" & r) = "" Then
  On Error GoTo ErrHandler
  Exit For
                End If

    
        'MsgBox "The file(s) can be found in: " & vbNewLine & dstPath, , "COPY COMPLETED"
        Range("A" & r).Copy Range("M" & r)
Next r
MsgBox "The file(s) can be found in: " & vbNewLine & dstPath, , "COPY COMPLETED"
Exit Sub

 
ErrHandler:
    MsgBox "Copy error: " & SourcePath & myFile & vbNewLine & vbNewLine & _
    "File could not be found in the source folder", , "MISSING FILE(S)"

    Range("A" & r).Copy Range("M" & r)
   ' Range("m" & r) = noFile

Resume Next

End Sub

 

[Marc L]

According to VBA basics a demonstration as a starting point :​

Sub Demo1()
    Dim P$, V, M$(), R&, C%
        P = [E1].Text
        V = [A1].CurrentRegion.Value2
        ReDim M(2 To UBound(V), 0)
    For R = 2 To UBound(V)
        If Dir(V(R, 2)) = "" Then
            M(R, 0) = "Missing"
        Else
            C = -(Dir(P & V(R, 1)) > "")
            FileCopy V(R, 2), P & V(R, 1)
            M(R, 0) = Array("Ok", "Overwritten")(C)
        End If
    Next
        [M2].Resize(R - 2).Value2 = M
End Sub

 

[Marc L]

opening explorer to define the destination folder is also preferable

A VBA demonstration to select a folder :​

Sub DemoFolder()
    Dim obj As Object, P$
    Set obj = CreateObject("Shell.Application").BrowseForFolder(0, vbLf & "Your message here :", 1, "")
     If obj Is Nothing Then Beep: Exit Sub Else P = obj.Self.Path & "\": Set obj = Nothing
    MsgBox P
End Sub

 

[wayne9606]

Sub Demo1() Dim P$, V, M$(), R&, C% P = [E1].Text V = [A1].CurrentRegion.Value2 ReDim M(2 To UBound(V), 0) For R = 2 To UBound(V) If Dir(V(R, 2)) = "" Then M(R, 0) = "Missing" Else C = -(Dir(P & V(R, 1)) > "") FileCopy V(R, 2), P & V(R, 1) M(R, 0) = Array("Ok", "Overwritten")(C) End If Next [M2].Resize(R - 2).Value2 = M End Sub

Perfect Marc. Any chance of an Explorer lookup and point to the destination instead of using E4. Regards Wayne b PS Love your work.

 

[Marc L]

​

See at least post #3 …​

 

[wayne9606]

​

See at least post #3 …​

With the help of Ken Puls VBA express I have modified your sub to run Kens Function. The difficulty is it is only picking up to the folder before the folder and appending the "p" to the filename. I must be getting tired because I cannot see what I am doing wrong.

sub Demo2()
     
     Dim p$, V, M$(), R&, C%
        'P = [E1].Text
       
           
      p = BrowseForFolder()
      MsgBox p 'this message box displays the correct path
      V = [A1].CurrentRegion.Value2
        ReDim M(2 To UBound(V), 0)
    For R = 2 To UBound(V)
        If Dir(V(R, 2)) = "" Then
            M(R, 0) = "Missing"
        Else
            C = -(Dir(p & V(R, 1)) > "")
            FileCopy V(R, 2), p & V(R, 1)
            M(R, 0) = Array("Ok", "Overwritten")(C)
        End If
    Next
        [M2].Resize(R - 2).Value2 = M
End Sub

Option Explicit
 
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     Dim Ret

   
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, "C:\Users\Big W\OneDrive\Documents")
    ' "C:\Users\Big W\OneDrive\Documents" = OpenAt)
     'Set the folder to that selected.  (On error in case cancelled)
    
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function

 

[wayne9606]

Got it

p = BrowseForFolder() & "\"

missing the back slash or at least it worked.

Regards Wayne b

 

[wayne9606]

Well things have got a little bit more complicated. I have the downloaded report from my ancestry database that is found via opening windows explorer and selecting. I then copy a range of cells and paste into a sheet RM8 and add to more columns with formulas to get the necessary data to copy and paste the files from one folder to another. At the moment it is falling over when Demo 2 Module is run from Module ReviseImportData. I think it has something to do with either text field on the copy and paste or not knowing which sheet it is on. Any help would be appreciated.

Sub RevisedImportData()
    
    Dim OpenBook As Workbook
    Dim TargetFile As String, msg As String, FileName As String, response As String
    Dim lngCount As Long, i As Long, x As Long, counter As Long
    Dim ws As Worksheet
    Dim LR As Long
   
   ThisWorkbook.Activate
   Sheets("Working").Select
   Worksheets("Working").UsedRange.Delete
   Sheets("RM8 Report").Select
    Worksheets("RM8 Report").UsedRange.Delete ' Delete previous data
       ' Open the file dialog
    With Application.FileDialog(3) '3 = msoFileDialogOpen
        .AllowMultiSelect = False
        If .Show = -1 Then
            For lngCount = 1 To .SelectedItems.Count
                Set OpenBook = Workbooks.Open(CStr(.SelectedItems(lngCount))) 'Assumes the workbook is not already open
                TargetFile = Dir(CStr(.SelectedItems(lngCount))) 'Not really sure why this is needed as the OpenBook variable suffices.
            Next lngCount
        Else
            Exit Sub
        End If
    End With
    
    Application.ScreenUpdating = False
    
   
  Sheets("Sheet 1").Select ' sheet name of exported report from ancestry database
    Worksheets("Sheet 1").UsedRange.Copy
    ThisWorkbook.Activate
   
    Worksheets("RM8 Report").Range("A1").PasteSpecial Paste:=xlPasteValues
     ActiveSheet.UsedRange.RemoveDuplicates Columns:=2, Header:=xlYes 'remove duplicate files
     
     LR = Cells(Rows.Count, 1).End(xlUp).Row    '<---- Change the 1 (one) to the column number you're counting the rows in
    With Range("c2:c" & LR)    '<---- Do you want the formula in Column X
        'Formulas to trim out unneeded info in path and get actual filename (Calculated Cells)
        .Formula = "=MID(B2,FIND(""*"",SUBSTITUTE(B2,""\"",""*"",LEN(B2)-LEN(SUBSTITUTE(B2,""\"",""""))))+1,LEN(B2))"
  With Range("d2:d" & LR)
    '.Formula = "=RIGHT((B2),(LEN(B2)-10))"
  .Formula = "=RIGHT((B2),LEN(B2)- SEARCH(""*:"",(B2))+1)"
  End With
  End With
    
        Workbooks(TargetFile).Close SaveChanges:=False
    Application.ScreenUpdating = True

    
    ' Copy and paste calculated cells in Sheet "RM8 Report" to sheet "Working" as text
    'Module6.CopyToNewWorkSheet
    Module21.PasteSpecial_ValuesOnly
     'ThisWorkbook.Activate
 'Copies files from source folder to destination folder
Module18.Demo2

End Sub

Sub Demo2()
     
     Dim p$, V, M$(), R&, C%
        
           
      p = BrowseForFolder() & "\"
        Sheets("Working").Select
        V = [A1].CurrentRegion.Value2
        ReDim M(2 To UBound(V), 0)
    For R = 2 To UBound(V)
        If Dir(V(R, 2)) = "" Then ' falling over here!!!! Had working very well.
            M(R, 0) = "Missing"
        Else
            C = -(Dir(p & V(R, 1)) > "")
            FileCopy V(R, 2), p & V(R, 1)
            M(R, 0) = Array("Ok", "Overwritten")(C)
        End If
    Next
        [M2].Resize(R - 2).Value2 = M
End Sub

Sub PasteSpecial_ValuesOnly()


'Copy A Range of Data
  Sheets("RM8 Report").Select
    Range("c2:d2", Range("c2").End(xlDown)).Select
    Selection.Copy
'PasteSpecial Values Only
  Worksheets("Working").Range("A1").PasteSpecial Paste:=xlPasteValues

'Clear Clipboard (removes original data set)
  Application.CutCopyMode = False
End Sub

 

[Marc L]

Do not Activate any workbook, any worksheet as a good enough VBA procedure does not need it​

but just qualify the worksheet (and maybe the workbook) before each Range when this range is not located on the active worksheet …​

 

[wayne9606]

​

Do not Activate any workbook, any worksheet as a good enough VBA procedure does not need it​

but just qualify the worksheet (and maybe the workbook) before each Range when this range is not located on the active worksheet …​

Thanks Marc I found the issue. I tried to be a smartarse and change one of the pasted formulas to include a wildcard instead of hardcoding c: and forgot to test. That errored your code out. I hope you did not vomit as much when you saw todays stuff. It needs fixing but it works. Regards Wayne b