VBA: Multiply a file (copy) and rename all after list - excel

Question

I had a .bat file that worked but I need this in VBA now.
I tried different approches but only managed to do this with one file at a time. So I keep starting over and over.
So:
I have a file (named 1.pdf)
I have on a excel on Sheet1 (starting with A2) a list of file names
I need VBA to create a folder named ABC (where-ever the Excel macro is located) and multiply 1.pdf as many times as needed and rename the copies with every name in the excel list.
Example:
(i have in the same folder as the macro 1.pdf) and in Excel:
A1
John.pdf
Dog.pdf
Triangle.pdf
After execution this would result in 1.pdf copied and renamed with all of those 3 names uploaded into folder :ABC
In command prompt woud look like:
if not exist "ABC\" mkdir %cd%\ABC\
copy "1.pdf" "ABC"
ren "ABC\1.pdf" "John.pdf"
copy "1.pdf" "ABC"
ren "ABC\1.pdf" "Dog.pdf"
copy "1.pdf" "ABC"
ren "ABC\1.pdf" "Triangle.pdf"

Answer 1

Something like this should work for you:
Sub CopyFileForEachName()
Dim rRenameList As Range
Dim rNameCell As Range
Dim sFileToCopyPath As String
Dim sFolderPath As String
Dim sFileName As String
Dim sExt As String
Dim sNewSubFolder As String
Dim sCopyErr As String
Dim sResultsMsg As String
Dim lSuccessfulCopies As Long
Dim i As Long
'These are invalid characters for the subfolder name (the double quote "" will be evaluated as a single double quote")
Const sInvalidChar As String = "\/:*?""<>|"
If Len(ActiveWorkbook.Path) > 0 Then ChDir ThisWorkbook.Path 'Start in same folder as the active workbook
sFileToCopyPath = Application.GetOpenFilename("All Files, *.*") 'Prompt user to select file to copy
If sFileToCopyPath = "False" Then Exit Sub 'Pressed cancel
sFolderPath = Left(sFileToCopyPath, InStrRev(sFileToCopyPath, Application.PathSeparator)) 'Extract the folder path
sExt = Mid(sFileToCopyPath, InStrRev(sFileToCopyPath, ".")) 'Extract the extension
'Prompt user to select the range of cells that contain the rename list
'Pressing cancel will cause an error, resume next will suppress the error and GoTo 0 will remove the On Error condition
On Error Resume Next
Set rRenameList = Application.InputBox("Select the cells that contain the rename list.", "Rename Cells Selection", Selection.Address, Type:=8)
On Error GoTo 0
If rRenameList Is Nothing Then Exit Sub 'Pressed cancel
'If the list of rename cells is ALWAYS in the same location, you can comment out the above code, and uncomment the following:
'With ActiveWorkbook.Sheets("Sheet1")
' Set rRenameList = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
' If .Row < 2 Then Exit Sub 'No data
'End With
'Prompt user to enter the destination subfolder name
'Change the Default parameter to provide a desired default subfolder name
sNewSubFolder = InputBox(Prompt:="Please enter the name of the subfolder that will store the copied and renamed files." & Chr(10) & _
"Note that if the subfolder doesn't already exist, it will be created.", _
Title:="Destination Subfolder", _
Default:="ABC")
If Len(Trim(sNewSubFolder)) = 0 Then Exit Sub 'Pressed cancel
'Verify valid subfolder name
For i = 1 To Len(sInvalidChar)
sNewSubFolder = Replace(sNewSubFolder, Mid(sInvalidChar, i, 1), " ")
Next i
sNewSubFolder = WorksheetFunction.Trim(sNewSubFolder)
If Right(sNewSubFolder, Len(Application.PathSeparator)) <> Application.PathSeparator Then sNewSubFolder = sNewSubFolder & Application.PathSeparator
'Attempt to create the subfolder
Err.Clear
On Error Resume Next
MkDir sFolderPath & sNewSubFolder
On Error GoTo 0
If Err.Number <> 0 Then
'Failed to create the subfolder
'Check if the folder already exists
If Len(Dir(sFolderPath & sNewSubFolder, vbDirectory)) = 0 Then
'Subfolder does NOT exist, the provided subfolder name must be invalid
MsgBox "Unable to create subfolder named [" & Replace(sNewSubFolder, Application.PathSeparator, "") & "] because it is an invalid name." & Chr(10) & "Exiting macro."
Exit Sub
Else
'Subfolder already exists, got error due to duplicate name
Err.Clear
End If
End If
'Loop through each cell and rename the file
For Each rNameCell In rRenameList.Cells
'Make sure to use the extension of the file being copied
If Right(rNameCell.Text, Len(sExt)) = sExt Then
sFileName = Replace(rNameCell.Text, sExt, "")
Else
sFileName = rNameCell.Text
End If
'Attempt to copy and rename the file to the destination subfolder
Err.Clear
On Error Resume Next
FileCopy sFileToCopyPath, sFolderPath & sNewSubFolder & sFileName & sExt
On Error GoTo 0
'Record successes and failures
If Err.Number <> 0 Then
sCopyErr = sCopyErr & Chr(10) & sFileName & sExt
Else
lSuccessfulCopies = lSuccessfulCopies + 1
End If
Next rNameCell
'Build results message
sResultsMsg = "Successfully copied [" & sFileToCopyPath & "] " & lSuccessfulCopies & " times into subfolder [" & sNewSubFolder & "]"
If Len(sCopyErr) > 0 Then
sResultsMsg = sResultsMsg & Chr(10) & Chr(10) & "Failed to copy with the following names: " & Chr(10) & sCopyErr
End If
'Display results message
MsgBox sResultsMsg
End Sub