How To Copy All Files From One Folder To Another Based On A List of Unique Identification Number (UIN) in Excel ?

K

kychong79

New Member
Joined
Nov 21, 2020
Messages
8
Office Version
  1. 2019
Platform
  1. Windows
Hi All,

I have multiple files with different national ID numbers under the source folder, most of the multiple files are named under the same national ID number with additional descriptive text example s12345678B_forms, s12345678B_resume_work permit, licence_s12345678B. Anyone knows the code to copy all the files associate with the national id numbers? I would appreciate any kind souls that would be able to help me with the code on this.

VBA Code: 
Dim blNotFirstIteration As Boolean
Dim Fil As File
Dim hFolder As Folder, SubFolder As Folder
Dim NameOfFile As String
Dim FSO As Scripting.FileSystemObject

Sub copyfiles()
'Updateby JHey
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the file names:", "ID", ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = "Please select the original folder:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & ""
    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = "Please select the destination folder:"
    If xDFileDlg.Show <> -1 Then Exit Sub
    xDPathStr = xDFileDlg.SelectedItems.Item(1) & ""
    For Each xCell In xRg
    blNotFirstIteration = False
        NameOfFile = ""
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
       FindFilesInFolders xSPathStr, xVal
            If NameOfFile <> "" Then
                FileCopy Fil.Path, xDPathStr & "\" & NameOfFile
         End If
        End If
    Next
End Sub

Sub FindFilesInFolders(ByVal HostFolder As String, FileName As String)
    If NameOfFile <> "" Then Exit Sub

    If FSO Is Nothing Then Set FSO = New Scripting.FileSystemObject
    Set hFolder = FSO.GetFolder(HostFolder)

    ' iterate through all files in the root of the main folder
    If Not blNotFirstIteration Then
      For Each Fil In hFolder.Files
          If InStr(1, FSO.GetFileName(Fil.Path), FileName) > 0 Then
              NameOfFile = FSO.GetFileName(Fil.Path)
              Exit Sub
          End If
      Next Fil
   
      ' make recursive call, if main folder contains subfolder
      If Not hFolder.SubFolders Is Nothing Then
          blNotFirstIteration = True
          Call FindFilesInFolders(HostFolder, FileName)
          If NameOfFile <> "" Then Exit Sub
      End If
   
    ' iterate through all files in all the subfolders of the main folder
    Else
      For Each SubFolder In hFolder.SubFolders
            For Each Fil In SubFolder.Files
                If InStr(1, FSO.GetFileName(Fil.Path), FileName) > 0 Then
                     NameOfFile = FSO.GetFileName(Fil.Path)
                     Exit Sub
                 End If
          Next Fil
   
          ' make recursive call, if subfolder contains subfolders
          If Not SubFolder.SubFolders Is Nothing Then
              Call FindFilesInFolders(HostFolder & "\" & SubFolder.Name, FileName)
              If NameOfFile <> "" Then Exit Sub
          End If
      Next SubFolder
    End If
    blNotFirstIteration = False
End Sub
 
Last edited by a moderator:

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
Sort by date Sort by votes
Hello kychong79,
I have something. Hope so that will be useful.
VBA Code: 
Option Explicit

Dim varParametar, varLocation, varLocation2 As String
Dim varNLoop  As Long
Dim varFile, varArray As Variant
Dim varI As Integer
Dim varFSO, varOFile, varOFolder, varOFiles As Object

  
Sub CopyByID()

    varParametar = Application.InputBox _
         ("Insert file parameter that you are want to be copied to the new location.")
    MsgBox ("Select location where you want to move specific files.")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
           varLocation2 = .SelectedItems(1)
        Else
            MsgBox ("Insert final destination folder.")
            Exit Sub
        End If
    End With
    MsgBox ("Select location from which you want to get specific files.")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            varLocation = .SelectedItems(1)
            varFile = listfiles(varLocation & "\")
            For varNLoop = 1 To varI - 1
                Dim varIsParametar
                varIsParametar = InStr(1, varArray(varNLoop), varParametar)
                If varIsParametar > 0 Then
                    varFSO.CopyFile varLocation & "\" & varArray(varNLoop), varLocation2 & "\"
                End If
            Next
        End If
    End With
 
End Sub


Function listfiles(ByVal sPath As String)

    Set varFSO = VBA.CreateObject("Scripting.FileSystemObject")
    Set varOFolder = varFSO.GetFolder(sPath)
    Set varOFiles = varOFolder.Files
    If varOFiles.Count = 0 Then Exit Function
    ReDim varArray(1 To varOFiles.Count)
    varI = 1
    For Each varOFile In varOFiles
        varArray(varI) = varOFile.Name
        varI = varI + 1
    Next
    
End Function
 
Upvote 0
EXCEL MAX said:
Hello kychong79,
I have something. Hope so that will be useful.
VBA Code: 
Option Explicit

Dim varParametar, varLocation, varLocation2 As String
Dim varNLoop  As Long
Dim varFile, varArray As Variant
Dim varI As Integer
Dim varFSO, varOFile, varOFolder, varOFiles As Object

 
Sub CopyByID()

    varParametar = Application.InputBox _
         ("Insert file parameter that you are want to be copied to the new location.")
    MsgBox ("Select location where you want to move specific files.")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
           varLocation2 = .SelectedItems(1)
        Else
            MsgBox ("Insert final destination folder.")
            Exit Sub
        End If
    End With
    MsgBox ("Select location from which you want to get specific files.")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            varLocation = .SelectedItems(1)
            varFile = listfiles(varLocation & "\")
            For varNLoop = 1 To varI - 1
                Dim varIsParametar
                varIsParametar = InStr(1, varArray(varNLoop), varParametar)
                If varIsParametar > 0 Then
                    varFSO.CopyFile varLocation & "\" & varArray(varNLoop), varLocation2 & "\"
                End If
            Next
        End If
    End With

End Sub


Function listfiles(ByVal sPath As String)

    Set varFSO = VBA.CreateObject("Scripting.FileSystemObject")
    Set varOFolder = varFSO.GetFolder(sPath)
    Set varOFiles = varOFolder.Files
    If varOFiles.Count = 0 Then Exit Function
    ReDim varArray(1 To varOFiles.Count)
    varI = 1
    For Each varOFile In varOFiles
        varArray(varI) = varOFile.Name
        varI = varI + 1
    Next
   
End Function
Click to expand...
Eternally grateful for the help! it works wonders. you are a genuis.
 
Upvote 0
EXCEL MAX said:
I'm glad that you find this code useful.
Click to expand...
Dear Excel Max, there is this issue. I have a range of national IDs number in my worksheet cells Column A but when I execute the code, selecting all the national IDs as the range for the file parameter input (=$A$1:$A$31), it only copy the files from 1 records instead of all 31 records. Please kindly advise.
 
Upvote 0
If I understand you want to apply this code to the ranges in the column "A" instead to looping through folder files?
Do you want some kind of modification?
 
Upvote 0
EXCEL MAX said:
If I understand you want to apply this code to the ranges in the column "A" instead to looping through folder files?
Do you want some kind of modification?
Click to expand...
Dear Max, i need to apply this code to the range values (national ID numbers) in column "A" to copy all the files names containing the national ID numbers from source folder to another folder. sorry for the confusion. Hope you can help me out here. Yes, i need modifications.
 
Upvote 0
OK kychong79,
here is new modified version.
VBA Code: 
Option Explicit

Dim varLocation1, varLocation2 As String
Dim varNLoop  As Long
Dim varRange1, varRange2 As Range
Dim varFile, varArray As Variant
Dim varI As Integer
Dim varFSO, varOFile, varOFolder, varOFiles As Object
Dim varNRows As Long

Sub CopyByID()

    MsgBox ("Select location from where you want to move specific files.")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
           varLocation1 = .SelectedItems(1)
        Else
            MsgBox ("Select location from where you want to move specific files.")
            Exit Sub
        End If
    End With
    MsgBox ("Select location where you want to move specific files.")
DESTINATION:
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
           varLocation2 = .SelectedItems(1)
        Else
            MsgBox ("Select location where you want to move specific files.")
GoTo DESTINATION
        End If
    End With
    varNRows = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    varFile = varListFiles(varLocation1 & "\")
    Set varRange2 = ActiveSheet.Range("A1:A" & varNRows)
    For Each varRange1 In varRange2
        For varNLoop = 1 To varI - 1
            If varArray(varNLoop) = varRange1.Value Then
                varFSO.CopyFile varLocation1 & "\" & varArray(varNLoop), varLocation2 & "\"
            End If
        Next
    Next varRange1
    Set varFSO = Nothing
    
End Sub

Function varListFiles(ByVal varPath As String)

    Set varFSO = VBA.CreateObject("Scripting.FileSystemObject")
    Set varOFolder = varFSO.GetFolder(varPath)
    Set varOFiles = varOFolder.Files
    If varOFiles.Count = 0 Then Exit Function
    ReDim varArray(1 To varOFiles.Count)
    varI = 1
    For Each varOFile In varOFiles
        varArray(varI) = varOFile.Name
        varI = varI + 1
    Next

End Function
 
Upvote 0
EXCEL MAX said:
OK kychong79,
here is new modified version.
VBA Code: 
Option Explicit

Dim varLocation1, varLocation2 As String
Dim varNLoop  As Long
Dim varRange1, varRange2 As Range
Dim varFile, varArray As Variant
Dim varI As Integer
Dim varFSO, varOFile, varOFolder, varOFiles As Object
Dim varNRows As Long

Sub CopyByID()

    MsgBox ("Select location from where you want to move specific files.")
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
           varLocation1 = .SelectedItems(1)
        Else
            MsgBox ("Select location from where you want to move specific files.")
            Exit Sub
        End If
    End With
    MsgBox ("Select location where you want to move specific files.")
DESTINATION:
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
           varLocation2 = .SelectedItems(1)
        Else
            MsgBox ("Select location where you want to move specific files.")
GoTo DESTINATION
        End If
    End With
    varNRows = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    varFile = varListFiles(varLocation1 & "\")
    Set varRange2 = ActiveSheet.Range("A1:A" & varNRows)
    For Each varRange1 In varRange2
        For varNLoop = 1 To varI - 1
            If varArray(varNLoop) = varRange1.Value Then
                varFSO.CopyFile varLocation1 & "\" & varArray(varNLoop), varLocation2 & "\"
            End If
        Next
    Next varRange1
    Set varFSO = Nothing
   
End Sub

Function varListFiles(ByVal varPath As String)

    Set varFSO = VBA.CreateObject("Scripting.FileSystemObject")
    Set varOFolder = varFSO.GetFolder(varPath)
    Set varOFiles = varOFolder.Files
    If varOFiles.Count = 0 Then Exit Function
    ReDim varArray(1 To varOFiles.Count)
    varI = 1
    For Each varOFile In varOFiles
        varArray(varI) = varOFile.Name
        varI = varI + 1
    Next

End Function
Click to expand...
Hi Max, thanks for your prompt response. I have tried but it doesn't copy any files over. Am i missing something here? I assume that since the values range has been declare under Set varRange2 = ActiveSheet.Range("A1:A" & varNRows), hence i do not need to select the range cells.
 
Upvote 0
Try this...
1. Check that you names of files is absolutly same as names in the sheet
2. When code start and first message box appear, select folder with files,
and when second message appears then select destination folder where you want to copy files
3. Activate sheet with IDs, or change this problematic line in the code to sheets("Your Sheet Name"). This is most important in this post.
If this not works...
4. Break code in this line and tell me what is value of the varNRows when code stop.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
VBA - How to add a loop to search through subfolders
Replies
1
Views
396
sijpie
sijpie
C
  • Solved
VBA listing folders, sub-folders & file names - modification required
Replies
5
Views
344
NdNoviceHlp
NdNoviceHlp
J
  • Solved
Copy files to specific folders from list in Excel
Replies
4
Views
3K
jolivanes
jolivanes
B
  • Solved
VBA macro to copy files from one folder (and all it's subfolders, and their subfolders, and their subfolders with an exception....) to another folder?
Replies
4
Views
652
Bering
B
J
  • Question
MOVE files from list found in folders/subfolders to same folder structure in another folder
Replies
0
Views
671
johnbrownbaby
J

Forum statistics

Threads
1,214,523
Messages
6,120,028
Members
448,940
Latest member
mdusw

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