Question

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

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

尝试重命名每行中的文件在所选范围行中的单元格（，5）+“_”+单元格（，2）中的内容。

我选择的范围是= $ A $ 3：$ E $ 6.

我收到了一个Object required错误。我在编写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

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

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

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

2 个答案: