VBA: Multiplizieren Sie eine Datei (kopieren) und benennen Sie alle nach der Liste

Question

Ich hatte eine .bat-Datei, die funktionierte, aber ich brauche das jetzt in VBA.

Ich habe verschiedene Ansätze probiert, aber nur mit einer Datei gleichzeitig. Also fange ich immer wieder an.

So:

1. Ich habe eine Datei (mit dem Namen 1.pdf)
2. ich auf einem Excel haben auf Sheet1 (beginnend mit A2) eine Liste von Dateinamen

Ich brauche VBA, um einen Ordner mit dem Namen ABC (wo immer das Excel-Makro befindet) zu erstellen und multiplizieren Sie 1.pdf so oft wie nötig und benennen Sie die Kopien mit jedem Namen in der Excel-Liste.

Beispiel:

(i im selben Ordner wie die Makro 1.pdf haben) und in Excel:

A1

• John.pdf
• Dog.pdf
• Triangle.pdf

Nach der Ausführung dieses in 1.pdf kopiert und umbenannt mit all diesen drei Namen hochgeladen in den Ordner führen würde: ABC

In Eingabeaufforderung woud wie folgt aussehen:

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

So etwas wie dies für Sie arbeiten sollten :

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