VBA copy based on list to specific directory.

chancech Posts 1 Registration date Tuesday May 10, 2016 Status Member Last seen May 10, 2016 - May 10, 2016 at 09:54 AM
Hi, I am attempting to copy a file with names from an excel list and copy them to a specific directory using VBA. I am using rizvisa1's code from https://ccm.net/forum/affich-689536-generate-excel-workbooks-based-on-excel-list as a base code. I have successfully gotten it to copy the correct file with the names in col A and col B but i also want to copy them to individual folders with a name in col D. So far it will save the files to the fixed path in the code but won't put them in the correct folders (or any for that matter.) I am still pretty new to VBA and am using Excel 2010 if it matters. I have included my code below.

Option Explicit

Sub copyTemplate()
Dim lRow, x As Integer
Dim wbName As String
Dim fso As Variant
Dim dic As Variant
Dim colA As String
Dim colB As String
Dim colSep As String
Dim copyFile As String
Dim copyTo As String
Dim colD As String

Set dic = CreateObject("Scripting.Dictionary") 'dictionary to ensure that duplicates are not created
Set fso = CreateObject("Scripting.FileSystemObject") 'file scripting object for fiile system manipulation

colSep = " - " 'separater between values of col A and col B for file name
dic.Add colSep, vbNullString ' ensuring that we never create a file when both columns are blank in between

'get last used row in col A
lRow = Range("A" & Rows.Count).End(xlUp).Row

x = 1

colD = Range("D" & x).Value 'Folder to save to

copyFile = "C:\Users\User\Documents\New folder\BackupDocs.xls" 'template file to copy
copyTo = "C:\Users\v5166302\Documents\New folder\Excel Test\" & colD & "\" 'location where copied files need to be copied

x = x + 1

colA = Range("A" & x).Value 'col a value

colB = Range("B" & x).Value ' col b value
colB = Left(Range("B" & x).Value, 20) 'only retain first 20 characters

wbName = colA & colSep & colB ' create new file name

If (Not dic.Exists(wbName)) Then 'ensure that we have not created this file name before
fso.copyFile copyFile, copyTo & wbName & ".xls" 'copy the file
dic.Add wbName, vbNullString 'add to dictionary that we have created this file
End If

Loop Until x = lRow

Set dic = Nothing ' clean up
Set fso = Nothing ' clean up

End Sub