Excel VBA:在数据的最后一行之后复制文件名,跳过已存在的文件
问题描述:
我有这样的代码。我选择一个文件夹,它将文件名复制到一个以A2开始的表中并创建超链接。现在,当我再次选择一个文件夹时,它会覆盖所有内容。我试图修改它,以便它跳过已添加的部分,并在包含数据的最后一行之后将新项插入到行中。任何意见如何写这将不胜感激。Excel VBA:在数据的最后一行之后复制文件名,跳过已存在的文件
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
答
你可以做到这一点的几种方法。由于您已经想出了如何将文件名添加到现有列表的底部,所以最简单的方法就是这样做,然后使用内置'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
谢谢。这看起来像会起作用。或者手动的方式是将新的批量项目添加到自己的文件夹中。谢谢 – DigitalSea