Excel VBA：在数据的最后一行之后复制文件名，跳过已存在的文件

Question

我有这样的代码。我选择一个文件夹，它将文件名复制到一个以A2开始的表中并创建超链接。现在，当我再次选择一个文件夹时，它会覆盖所有内容。我试图修改它，以便它跳过已添加的部分，并在包含数据的最后一行之后将新项插入到行中。任何意见如何写这将不胜感激。

Function LastRow(sh As Worksheet) 
    On Error Resume Next 
    LastRow = sh.Cells.Find(What:="*", _ 
          After:=sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
    On Error GoTo 0 
End Function  

Sub FileLinks() 
Dim objFSO As Object 
Dim objFolder As Object 
Dim objFile As Object 
Dim i As Integer 
Dim sItem As String 
Dim Last As Long 

With Application.FileDialog(msoFileDialogFolderPicker) 
    .Title = "Select a Folder" 
    .AllowMultiSelect = False 
    .InitialFileName = "S:\ACCOUNTING\Subcontracts\" 
    If .Show = -1 Then 
    'ok clicked 
    sItem = .SelectedItems(1) 
    On Error Resume Next 
    Err.Clear 
    Else 
    'cancel clicked 
    Exit Sub 
    End If 
End With 

'Create an instance of the FileSystemObject 
Set objFSO = CreateObject("Scripting.FileSystemObject") 
'Get the folder object 
Set objFolder = objFSO.GetFolder(sItem) 


Dim tbl As ListObject 
Dim sh As Worksheet 
Set sh = ActiveSheet 
For Each tbl In sh.ListObjects 
     With tbl.Sort 
     .SortFields.Clear 
     .SortFields.Add Key:=tbl.ListColumns("LINK TO FILE").Range, _ 
      SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 
     .Header = xlYes 
     .MatchCase = False 
     .Orientation = xlTopToBottom 
     .SortMethod = xlPinYin 
     .Apply 
    End With 
Next tbl 


i = 1 
'loops through each file in the directory 
For Each objFile In objFolder.Files 
    'select cell 
    Range(Cells(i + 1, 1), Cells(i + 1, 1)).Select 
    'create hyperlink in selected cell 
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _ 
     objFile.Path, _ 
     TextToDisplay:=objFile.Name 
    i = i + 1 
Next objFile 

Set objFolder = Nothing 
End Sub 

更新：下面

代码如何与数据LASTROW之后添加的文件名。只是添加新文件名时遇到问题。所以如果表中存在文件名，跳过文件。

'loops through each file in the directory 
For Each objFile In objFolder.Files 
Last = LastRow(sh) 
    'select cell 
    Range(Cells(Last + 1, 1), Cells(Last + 1, 1)).Select 
    'create hyperlink in selected cell 
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _ 
     objFile.Path, _ 
     TextToDisplay:=objFile.Name 
Next objFile 

Answer 1

你可以做到这一点的几种方法。由于您已经想出了如何将文件名添加到现有列表的底部，所以最简单的方法就是这样做，然后使用内置'remove duplicates'功能的excels来消除重复的记录。

或者，在将每条记录添加到列表末尾之前，可以检查它是否已经在列表中，如果是，请不要添加它。例如：

For Each objFile In objFolder.Files 
Last = LastRow(sh) 
    'select cell 
    Range(Cells(Last + 1, 1), Cells(Last + 1, 1)).Select 

    'Check if it's already in the list 
    alreadyThere = false 
    for i = 1 to range("A5000").end(xlup).row 
     if range("A"&i).value=objFile.Name then 
      alreadyThere = true 
      exit for 
     end if 
    next i 

    if not alreadyThere then 
     'create hyperlink in selected cell 
     ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _ 
      objFile.Path, _ 
      TextToDisplay:=objFile.Name 
    end if 

Next objFile