导入工作表后，超链接仅连接到一张工作表？

Question

我有一个 VBA，可以在不同的 Excel 中导入名为 support 的工作表。该片材称为支撑件。导入到目标工作簿后，它会创建一个超链接，其名称基于导入的 Excel 文件的标题。
问题是该链接仅适用于其中一张工作表，而忽略其余工作表。
我认为这是因为当询问要导入哪个工作表时，它需要支持，但随后在目标工作簿中，其余工作表将作为支持 (2)、支持 (3) 等导入。
有没有办法修改代码？

Sub ImportSheetsFromFolder()
    Dim folderPath As String
    Dim selectedFile As Variant
    Dim targetWorkbook As Workbook
    Dim sourceWorkbook As Workbook
    Dim sheetName As String
    Dim ws As Worksheet
    
    ' Prompt user to select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder Containing Excel Files"
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            MsgBox "No folder selected. Exiting."
            Exit Sub
        End If
    End With
    
    ' Set target workbook (current workbook)
    Set targetWorkbook = ThisWorkbook
    
    ' Prompt user for sheet name to import
    sheetName = InputBox("Enter the name of the sheet to import:", "Sheet Name")
    If sheetName = "" Then
        MsgBox "No sheet name provided. Exiting."
        Exit Sub
    End If
    
    ' Loop through each file in the selected folder
    selectedFile = Dir(folderPath & "\*.xlsx")
    
    Do While selectedFile <> ""
        ' Open source workbook
        Set sourceWorkbook = Workbooks.Open(folderPath & "\" & selectedFile)
        
        ' Check if the sheet exists in the source workbook
        On Error Resume Next
        Set ws = sourceWorkbook.Sheets(sheetName)
       
        On Error GoTo 0
        
        ' If the sheet exists, import it into the target workbook
       
        If Not ws Is Nothing Then
            ws.Copy After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count)
        End If
        
        Worksheets("Hyperlink").Select
'        Range("A1").Select <--Remove
       
        ' Create hyperlink for each sheet that was imported into seperate sheet in target WB
'        For Each ws In Worksheets <--Remove
        
        ' Check if the sheet name is not one of the excluded sheets
        If ws.Name <> "TB 460201" And ws.Name <> "Hyperlink" And ws.Name <> "Cover sheet" And ws.Name <> "Supporting details" And ws.Name <> "Data" Then
            ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:="" & ws.Name & "!A1" & "", ScreenTip:="", TextToDisplay:=sourceWorkbook.Name
            ActiveCell.Offset(1, 0).Select
        End If
       
        ' Close the source workbook without saving changes
        sourceWorkbook.Close False
        
        ' Move to the next file
        selectedFile = Dir
         
    Loop
   
    MsgBox "Import complete."
    
End Sub

Answer 1

这有效。我还稍微改变了逻辑。

Sub ImportSheetsFromFolder()
    Dim folderPath As String
    Dim selectedFile As Variant
    Dim targetWorkbook As Workbook
    Dim sourceWorkbook As Workbook
    Dim sheetName As String
    Dim ws As Worksheet

    ' Prompt user to select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder Containing Excel Files"
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            MsgBox "No folder selected. Exiting."
            Exit Sub
        End If
    End With

    ' Set target workbook (current workbook)
    Set targetWorkbook = ThisWorkbook

    ' Prompt user for sheet name to import
    sheetName = InputBox("Enter the name of the sheet to import:", "Sheet Name")
    If sheetName = "" Then
        MsgBox "No sheet name provided. Exiting."
        Exit Sub
    End If

    ' Loop through each file in the selected folder
    selectedFile = Dir(folderPath & "\*.xlsx")

    Do While selectedFile <> ""
        ' Open source workbook
        Set sourceWorkbook = Workbooks.Open(folderPath & "\" & selectedFile)

        ' Check if the sheet exists in the source workbook
        On Error Resume Next
        Set ws = sourceWorkbook.Sheets(sheetName)

        On Error GoTo 0

        ' If the sheet exists, import it into the target workbook

        If Not ws Is Nothing Then
            ws.Copy After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count)
            Dim newSheetName As String
            ' Close the source workbook without saving changes
            sourceWorkbook.Close False
            newSheetName = ActiveSheet.Name
            Worksheets("Hyperlink").Select
            '        Range("A1").Select <--Remove

            ' Create hyperlink for each sheet that was imported into seperate sheet in target WB
            '        For Each ws In Worksheets <--Remove

            ' Check if the sheet name is not one of the excluded sheets
            If newSheetName <> "TB 460201" And newSheetName <> "Hyperlink" And newSheetName <> "Cover sheet" And newSheetName <> "Supporting details" And newSheetName <> "Data" Then
                ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:="'" & newSheetName & "'!A1" & "", ScreenTip:="", TextToDisplay:=selectedFile
                ActiveCell.Offset(1, 0).Select
            End If

        End If

        ' Move to the next file
        selectedFile = Dir

    Loop

    MsgBox "Import complete."

End Sub