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

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

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

代码

像这样的

我使用了中的代码直接处理

xlsx

文件

此外，我还改进了变量的使用，以处理您正在使用的工作簿

代码也可能来自错误处理（如目标工作表不存在等）

---

谢谢你，布雷特。这正是我所需要的。我尝试过类似的方法，但没有像您的示例中那样声明范围。我将添加错误处理，我只是想让它首先工作。再次感谢！

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

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