Excel VBAsearch目录并在新的工作簿中添加超链接到目录工作簿

我正在使用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

像这样的东西

我已经使用我的代码循环通过使用VBA文件夹中的文件？ 直接使用xlsx文件。

此外，我改进了使用variables来处理您正在使用的工作簿

代码也可以从error handling（即目标表不存在等）

 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