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

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

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

正在尝试将每行中的文件重命名为选定范围行中的单元格（，5）+“”+单元格（，2）中的文件

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

我得到一个对象必需的错误。我无法为每个部分编写

。尤其是获取文件路径，即
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

我不是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
的末尾添加一个
\
，我可能保留输入框，也可能不保留输入框。输入框范围将是仅从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

出现“需要对象”错误，因为您试图在InputBox方法中将
rng
设置为文本值。请提供一些额外的指导。我将
类型：=2更改为8。仍然有错误。您能否提供有关从超链接中提取文件路径的帮助？我有点卡住了…输入框的用途是什么？对于rng.Hyperlinks中的每个myLink，类似于
的东西怎么样？另外，您是否可以包含每个列的示例？我添加了一个到测试工作簿的链接和它的图像。谢谢你。我很快就会测试这个。我试图做到的是：我将拥有100多行指向不同文件夹中pdf文件的链接。我想收集一系列经过筛选的链接，并将这些文件复制到一个重命名的文件夹中，以便它们在该文件夹中按供应商名称顺序排列。我倾向于允许重复。我有一个IF语句，我需要嵌入其中来处理它。多谢！获得了复制文件的代码。一些不起作用的事情：1。我在以下位置收到类型不匹配错误：
destFile=destPath+Cells（cell.Parent.row，5）+“”+Cells（cell.Parent.row，2）+I+”+sourceExtension
。2.它正在复制筛选范围的所有行。我需要它来排除隐藏的行。任何帮助都将不胜感激。谢谢，我试过
如果不是rng.EntireRow.Hidden，那就
但是不行。我正在应用自动筛选，然后我只想在可见行上运行代码。修复了类型不匹配错误：正确的代码是
destFile=destPath+Cells（cell.Parent.row，5）+“+”Cells（cell.Parent.row，2）+“-”&I&sourceExtension
对不起，我坐了一整天飞机。。。关于使用选定范围内的可见单元格，请尝试
Set rng=this工作簿.ActiveSheet.Application.Selection.SpecialCells（xlCellTypeVisible）
我刚将
单元格更改为
hlink
，我很高兴你已经全部搞定了。对不起，我不能花更多的时间亲自帮忙。