使用 VBA 将文件从一个目录复制到另一个目录

Question

第一题：

我有一个包含这样一列的 Excel 文件：

我需要的是：

第二个问题

每个选项都需要不同的 Sub 吗？

这是我的代码

选项显式

公共 CarpetaSeleccionada 作为字符串

子 CopiarArchivosFacturas()

UserForm1.Show vbModal 如果 CarpetaSeleccionada = "" 那么 MsgBox "您必须选择一个源文件夹。", vbCritical, "错误" 退出子 结束如果

' 1. Open an Excel file determined by the user
Dim archivo As Variant
archivo = Application.GetOpenFilename("Excel File's (.xls;.xlsx), .xls;.xlsx")

If TypeName(archivo) = "Boolean" Then Exit Sub 'If the user cancels the selection

Dim wb As Workbook
Set wb = Workbooks.Open(archivo)

' 2. Search for the word "invoices" in the Excel sheet
Dim hoja As Worksheet
Set hoja = wb.Sheets(1)

Dim palabra As String
palabra = "Invoice Number"

' 3. Locate and indicate in which column and row the word "invoices" is located
Dim rangoBusqueda As Range
Set rangoBusqueda = hoja.UsedRange

Dim celda As Range
Set celda = rangoBusqueda.Find(palabra)

Dim FIL As Long
Dim COL As Long
FIL = celda.Row
COL = celda.Column

' 4. Display the form for the user to select the source folder
UserForm1.Show
If CarpetaSeleccionada = "" Then
    MsgBox "Debe seleccionar una carpeta de origen.", vbCritical, "Error"
    Exit Sub
End If

' 5. Build source path based on user selection
Dim rutaOrigen As String
rutaOrigen = "C:\" & CarpetaSeleccionada & "\"

' 6. Prompt user to select destination folder
Dim rutaDestino As String
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Seleccione la carpeta de destino"
    .InitialFileName = "C:"
    .Show
    If .SelectedItems.Count = 0 Then
        MsgBox "Debe seleccionar una carpeta de destino.", vbCritical, "Error"
        Exit Sub
    Else
        rutaDestino = .SelectedItems(1) & ""
    End If
End With



 ' 7. Create  the object FileSystemObject
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")




' 8. Copy all files found under the invoices cell that match the files in both folders and subfolders in the source directory
Dim archivoFactura As Range
Dim i As Long

For i = FIL + 1 To hoja.Cells(hoja.Rows.Count, COL).End(xlUp).Row
    Set archivoFactura = hoja.Cells(i, COL)
    Dim nombreArchivoFactura As String
    nombreArchivoFactura = archivoFactura.Value

    CopiarArchivoRecursivo rutaOrigen, rutaDestino, nombreArchivoFactura, fso
Next i


' 9. Close the Excel file
wb.Close SaveChanges:=False

'10.-
MsgBox "Proceso finalizado", vbInformation, "Operación completada"

结束子

Sub CopiarArchivoRecursivo（ByVal rutaOrigen 作为字符串，ByVal rutaDestino 作为字符串，ByVal nombreArchivoFactura 作为字符串，ByRef fso 作为对象） Dim archivoEncontrado 作为对象 Dim archivoCopiado 作为布尔值 archivoCopiado = 假

' Find and copy files that match the invoice name
For Each archivoEncontrado In fso.GetFolder(rutaOrigen).Files
    If InStr(1, archivoEncontrado.Name, nombreArchivoFactura, vbTextCompare) > 0 Then
        Dim newFileName As String
        newFileName = archivoEncontrado.Name
        Dim counter As Integer
        counter = 1
        While fso.FileExists(rutaDestino & newFileName)
            newFileName = fso.GetBaseName(archivoEncontrado.Name) & "(" & counter & ")." & fso.GetExtensionName(archivoEncontrado.Name)
            counter = counter + 1
        Wend
        fso.CopyFile archivoEncontrado.Path, rutaDestino & newFileName, True
        archivoCopiado = True
    End If
Next archivoEncontrado

' If file is not found in source folder, search subfolders recursively
If Not archivoCopiado Then
    Dim carpeta As Object
    For Each carpeta In fso.GetFolder(rutaOrigen).SubFolders
        CopiarArchivoRecursivo carpeta.Path, rutaDestino, nombreArchivoFactura, fso
    Next carpeta
End If

结束子

我试图制作选项表格，但它给了我一个错误，程序被阻止了。