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.
Thanks!
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
Do 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
