Question

我有以下VBA代码：

Sub Hyperlink()
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim i As Integer

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("S:\Promigen Orders")
i = 1

For Each objFile In objFolder.Files

Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select

ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
objFile.Path, TextToDisplay:=objFile.Name

Range(Cells(i + 1, 2), Cells(i + 1, 2)) = FileDateTime(objFile)

i = i + 1
Next objFile
End Sub

代码工作正常，它找到所需的文件夹，创建一个列表，指向该文件的超链接，然后在每个超链接旁边，它还显示文件的最后修改日期。

我的问题是，每次运行代码时，它都会从头开始更新。我想要它只是添加新文件（上次运行代码后放入文件夹的文件）。我还希望链接始终按照修改的最后日期（从最旧到最新）的顺序排列。

换句话说，它只能添加我的Excel工作表上尚未存在的文件的超链接。

我的代码如何编辑才能执行此操作？

Answer 1

也许这样的事情会起作用（或者它可能会提供一些想法）：

Sub Hyperlink()

Dim objFSO As Object, objFolder As Object, objFile As Object, ObjRange As Range

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("S:\Promigen Orders")

For Each objFile In objFolder.Files

    ' Find the Object in your list, if it exists.
    Set ObjRange = Nothing
    On Error Resume Next
    Set ObjRange = Range("A:A").Find(What:=objFile.Name, LookIn:=xlValues, LookAt:=xlWhole)
    On Error GoTo 0

    ' If it does not exist, add it to the list, at the end & create the hyperlink.
    If ObjRange Is Nothing Then
        ' The reason I have so many .End(xlDown)'s is because I can't be sure if you have titles or not, and this may effect where the "last" cell is
        Set ObjRange = Range("A1").End(xlDown).End(xlDown).End(xlDown).End(xlUp).Offset(1)
        ActiveSheet.Hyperlinks.Add Anchor:=ObjRange, Address:=objFile.Path, TextToDisplay:=objFile.Name
    End If

    ' In either case, update the file date time value.
    ObjRange.Offset(0, 1).Value = FileDateTime(objFile)

Next objFile

' Sort by Modified Date
With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A:B"): .Header = xlYes: .MatchCase = False: .Orientation = xlTopToBottom
    .SortMethod = xlPinYin: .Apply
End With

End Sub

根据FileDateTime仅添加新的超链接和订单

1 个答案: