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

Question

I am using VBA to loop through a specified directory, open excel workbooks that exist in the directory, copy a range from a worksheet and paste the contents to a new workbook.

• In the new workbook, I want to add a hyperlink to the workbook that was copied.
• Here is the code I am using to open, copy, and paste.
• How can I add a hyperlink to the "StrFile" in the last column of my new workbook?

code

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

Something like this

I have used my code from Loop through files in a folder using VBA? to work with the xlsx files directly.

Also I have improved the use of variables to handle the workbooks you are working with

The code would also beenfit from error handling (ie if Target Sheet wasn't present etc)

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