Excel VBA 搜索目录并在新工作簿中添加指向目录工作簿的超链接

Question

我正在使用 VBA 循环指定目录，打开目录中存在的 excel 工作簿，从工作表中复制一个范围并将内容粘贴到新工作簿中。

• 在新工作簿中，我想向复制的工作簿添加超链接。
• 这是我用来打开、复制和粘贴的代码。
• 如何在新工作簿的最后一列中添加指向“StrFile”的超链接？

代码

Private Sub LoopThroughFiles()

Dim x As Workbook
Dim y As Workbook

' Create new workbook, name file, name sheets, set target directory
    Set NewBook = Workbooks.Add
        With NewBook
            .SaveAs Filename:="C:\NewFileName" _
                & Format(Date, "yyyymmdd") & ".xlsx"
            NewBook.Sheets("Sheet1").Name = ("NewSheet")
        End With

Dim dirName As String
' this is the directory to open files from
dirName = ("C:\TargetDirectory\") 

Dim StrFile As String
StrFile = Dir(dirName & "*.*")
Do While Len(StrFile) > 0
    If Right(StrFile, 4) = "xlsx" Then                  ' Filter for excel files
    Workbooks.Open (dirName & StrFile)                  ' Open the workbook
        Worksheets("TargetSheet").Range("A2:AA2").Copy  ' Copy paste to new book
        NewBook.Sheets("NewSheet").Columns("A").Find("", Cells(Rows.Count, "A")).PasteSpecial (xlPasteValuesAndNumberFormats)

    Application.DisplayAlerts = False
    Workbooks(StrFile).Close False    ' Close target workbook without saving
    Application.DisplayAlerts = True
End If
StrFile = Dir

Loop

End Sub

Answer 1

类似的东西

我已使用来自Loop through files in a folder using VBA? 的代码直接处理xlsx 文件。

我还改进了使用变量来处理您正在使用的工作簿

代码也将适应错误处理（即，如果 目标表 不存在等）

Private Sub LoopThroughFiles()

Dim NewBook As Workbook
Dim WB As Workbook
Dim rng1 As Range


' Create new workbook, name file, name sheets, set target directory
Set NewBook = Workbooks.Add
With NewBook
   .SaveAs Filename:="C:\temp\file" _
               & Format(Date, "yyyymmdd") & ".xlsx"
  .Sheets(1).Name = ("NewSheet")
End With


Dim dirName As String
' this is the directory to open files from
dirName = ("C:\temp\")

Dim StrFile As String
StrFile = Dir(dirName & "*.xlsx")

Application.DisplayAlerts = False
Do While Len(StrFile) > 0
     Set WB = Workbooks.Open(dirName & StrFile)                   ' Open the workbook
     WB.Worksheets("TargetSheet").Range("A2:AA2").Copy  ' Copy paste to new book
     Set rng1 = NewBook.Sheets("NewSheet").Columns("A").Find("", Cells(Rows.Count, "A"))
     rng1.PasteSpecial xlPasteValuesAndNumberFormats
     NewBook.Sheets(1).Hyperlinks.Add NewBook.Sheets(1).Cells(rng1.Row, "AB"), dirName & StrFile, dirName & StrFile
     WB.Close False    ' Close target workbook without saving
StrFile = Dir
Loop
Application.DisplayAlerts = True

End Sub