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

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

1 个答案: