根据工作表中的数据复制/重命名文件批次

Question

我在 A 列中有一个列表，其中包含指向共享网络驱动器上的 PDF 文件的文件名超链接，该驱动器经常被过滤和排序。我想在选定的过滤范围上运行宏，不包括表中的隐藏行。宏会将这些文件复制到新位置，并根据工作表中的数据重命名它们。

A 列包含包含扩展名的超链接文件名（例如，单元格“A3”包含“15-P980_Vendor_15169_.pdf”） B 列和 E 列包含基于从文件名中提取文本的公式的文本。下划线是分隔符。 （C 列和 D 列被隐藏，未使用）。因此，单元格“B3”包含“15-P980”，单元格“E3”包含来自 A 列中文件名的“供应商”。

尝试重命名所选范围行中每行中的文件 Cell(, 5) + "_" + Cell(, 2) 中的内容。

我选择的范围为 =$A$3:$E$6。

我收到一个需要对象的错误。我在编写For Each 部分时遇到问题。特别是获取文件路径，即sourcePath =。我想我必须获取 A 列中的超链接地址，然后从中提取文件路径，但不知道如何编码。任何帮助将不胜感激。

Sub CopyFile()
ThisWorkbook.ActiveSheet.Unprotect
    On Error GoTo errHndl
    Dim xTitleId As String
    Dim sourcePath As String, destPath As String
    Dim sourceFile As String, destFile As String, sourceExtension As String
    Dim rng As Range, cell As Range, row As Range


    destPath = "C:\Users\\Desktop\Test\dst"
    sourceFile = ""
    destFile = ""

    xTitleId = "Copy/Rename Files"
    Set rng = ThisWorkbook.ActiveSheet.Application.Selection
    Set rng = ThisWorkbook.ActiveSheet.Application.InputBox("Range", xTitleId, rng.Rows, Type:=8)
    Set addr = rng.Cells(, 1)

    For Each row In rng.Rows
      sourcePath = addr.Hyperlinks(1).Address 
      sourceExtension = Split(row.Cells(, 1), ".")(1)
      sourceFile = sourcePath + row.Cells(, 1)
      destFile = destPath + row.Cells(, 5) + "_" + row.Cells(, 2) + "." +  sourceExtension
      File.Copy sourceFile, destFile, False
    Next row


    MsgBox "Operation was successful.", vbOKOnly + vbInformation, "Done"
    Exit Sub

errHndl:
    MsgBox "Error happened while working on: " + vbCrLf + _
        sourceFile + vbCrLf + vbCrLf + "Error " + _
        Str(Err.Number) + ": " + Err.Description, vbCritical + vbOKOnly, "Error"

End Sub

Answer 1

我不是 100% 确定您要完成什么，但是为了分别提取文件名和路径，而不是遍历范围对象，我采用了循环遍历超链接集合的方法...

For Each linky In rng.Hyperlinks

    sourcePath = Left(linky.Address, Len(linky.Address) - Len(linky.TextToDisplay))

    sourceExtension = ".pdf" 'Split(row.Cells(, 1), ".")(1)
    sourceFile = linky.Address
    destFile = destPath + Cells(linky.Parent.row, 5) + "_" + Cells(linky.Parent.row, 2) + sourceExtension
    fso.CopyFile sourceFile, destFile, False
Next linky

您必须小心可能的文件重复，这会引发错误。 另外，我注意到您可能需要在 destpath 末尾添加 \。

Answer 2

我可能会也可能不会保留输入框。输入框范围将是仅从 A 列中选择的超链接。唯一不起作用的是在自动过滤范围内运行此宏。我让它工作了一段时间，但是当我清除自动过滤器并重新应用它时，宏再次包含隐藏的行。不知道如何解决...

同时处理重复的代码修订：

Sub CopyFile()
ThisWorkbook.ActiveSheet.Unprotect
    On Error GoTo errHndl
    Dim fso As New FileSystemObject
    Dim xTitleId As String
    Dim sourcePath As String, destPath As String
    Dim sourceFile As String, destFile As String, sourceExtension As String
    Dim rng As Range, cell As Hyperlink, row As Range
    Dim i As Long


    destPath = "C:\Users\Accounting\Desktop\Invoices To Be Paid with Weekly Check Run\"
    sourceFile = ""
    destFile = ""

    xTitleId = "Copy file from hyperlink"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set rng = ThisWorkbook.ActiveSheet.Application.Selection

    'On Error Resume Next
    'Set rng = ThisWorkbook.ActiveSheet.Application.InputBox("Range", xTitleId, rng.Address, Type:=8)
    'On Error GoTo 0

If rng.Hyperlinks.Count > 0 Then
 For Each cell In rng.Hyperlinks
    If Not rng.EntireRow.Hidden Then
        sourcePath = Left(cell.Address, Len(cell.Address) - Len(cell.TextToDisplay))
        sourceExtension = ".pdf"
        sourceFile = cell.Address
        destFile = destPath + Cells(cell.Parent.row, 5) + "_" + Cells(cell.Parent.row, 2) + sourceExtension
        i = 0
JumpHere:
        If Dir(destFile) = "" Then
        fso.CopyFile sourceFile, destFile, False
        Else
        i = i + 1
        destFile = destPath + Cells(cell.Parent.row, 5) + "_" + Cells(cell.Parent.row, 2) + "-" & i & sourceExtension
        GoTo JumpHere
        End If
    End If
 Next cell
Else
MsgBox "Cell does not contain a hyperlink"
Exit Sub
End If


    MsgBox "Operation was successful.", vbOKOnly + vbInformation, "Done"


    Exit Sub

errHndl:
    MsgBox "Error happened while working on: " + vbCrLf + _
        sourceFile + vbCrLf + vbCrLf + "Error " + _
        Str(Err.Number) + ": " + Err.Description, vbCritical + vbOKOnly, "Error"

End Sub

更正：

Set fso = CreateObject("Scripting.FileSystemObject")
Set rng = ThisWorkbook.ActiveSheet.Application.Selection.SpecialCells(xlCellTypeVisible)



If rng.Hyperlinks.Count > 0 Then
 For Each hlink In rng.Hyperlinks
        sourcePath = Left(hlink.Address, Len(hlink.Address) - Len(hlink.TextToDisplay))
        sourceExtension = ".pdf"
        sourceFile = hlink.Address
        destFile = destPath + Cells(hlink.Parent.row, 5) + "_" + Cells(hlink.Parent.row, 2) + sourceExtension
        i = 0
JumpHere:
        If Dir(destFile) = "" Then
        fso.CopyFile sourceFile, destFile, False
        Else
        i = i + 1
        destFile = destPath + Cells(hlink.Parent.row, 5) + "_" + Cells(hlink.Parent.row, 2) + "-" & i & sourceExtension
        GoTo JumpHere
        End If
 Next hlink
Else
MsgBox "Selection does not contain a hyperlink"
GoTo Cancel
End If