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

像这样

我已经使用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