Hyperlink a worksheet in another workbook

divinedar

New Member
Joined
Nov 2, 2009
Messages
16
I have the following code:

For i = 15 To 19
'Column A
c.Offset(0, 0).Value = strFileName
'--
strFormula = "='[" & strFileName & "]" & strSheetName & "'!"
'Column C
c.Offset(0, 2).Value = strSheetName
Dim n As Long, curtsht As Worksheet

Set curtsht = ThisWorkbook.Worksheets("SUMMARY")
LastRow = MyUsedRange()

' char3 = Mid(strSheetName, 3, 1)
If wks = strSheetName Then
wks.Hyperlinks.Add _
Anchor:=curtsht.Cells(LastRow, 3), _
Address:="", _
SubAddress:=wks.Name & "!A1", _
TextToDisplay:=wks.Name
End If
Selection.NumberFormat = "00.000"
'Column D
c.Offset(0, 3).Value = strFormula & "H11"
'Column E
c.Offset(0, 4).Formula = strFormula & "B" & i
'Column G
c.Offset(0, 6).Value = strFormula & "C" & i
'Column H
c.Offset(0, 7).Value = strFormula & "D" & i
'Column I
c.Offset(0, 8).Value = strFormula & "E" & i
'Column J
c.Offset(0, 9).Value = strFormula & "R" & i
Set c = c.Offset(1, 0)
Next i
LabNextSheet:
Next wks

I need for the part of the code above that is red to hyperlink to the cell that is in blue.

I have tried several and none seem to work. Understand the data that is being imported is from a closed workbook (opens, adds data, closes). I am trying to hyperlink to the worksheet in the closed workbook.

Any ideas anyone. Help would be most appreciated. Thank you.
 

Some videos you may like

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

divinedar

New Member
Joined
Nov 2, 2009
Messages
16
I found a solution to my question here:

Code:
Sub LoopAllFilesGetMTL_v2()
     ' Declaration section 'RB: moved inside the procedure to "limit the scope" of the variables.
    Dim WorkBk As Workbook
    Dim wks As Worksheet
    Dim SummarySheet As Worksheet
    Dim FirstBlankCll As Range 'RB: given a more meaningful name than... 'Dim c As Range
    Dim Filename As String
    Dim FolderPath As String
    Dim SelectedFiles As Variant
    Dim NFile As Variant
    Dim NRow As Long
    Dim SummarySheetLastRow As Long
    Dim strSheetName As String
    Dim arr As Variant
    Dim i As Long
    Dim FName As String
    Dim targetWS As Worksheet
    Dim nextAvlbleCllInColA As Range
     
     '
     'Setup
    With Application
        .ScreenUpdating = False 'speed up macro execution
        .EnableEvents = False 'turn off other macros for now
        .displayAlerts = False 'turn off system messages for now
    End With
     
     'Next line is bad since it will prevent any errors from being seen
     'On Error Resume Next ' recommend commenting it out
     
     ' Create a new workbook and set a variable to the first sheet & the target worksheet.
    With ThisWorkbook
        Set SummarySheet = .Sheets("WBS_MTL")
        Set targetWS = .Worksheets("WBS_Hours")
    End With
    SummarySheet.Select
     
     ' Modify this folder path to point to the files you want to use.
    FolderPath = "N:\Proposals\FY2007\P0756 NG\PROPOSAL FILES\SUBMITTALS\Rev S2 - Discount Submitted\"
'    FolderPath = ThisWorkbook.path
     
     ' Set the current directory to the the folder path.
    ChDrive FolderPath
    ChDir FolderPath
     
     ' Open the file dialog box and filter on Excel files, allowing multiple Files
     ' to be selected.
    SelectedFiles = Application.GetOpenFilename( _
    filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
     
    If IsArray(SelectedFiles) Then
         ' NRow keeps track of where to insert new rows in the destination workbook.
        NRow = 3 'starting number of row where the data is to be copied.
         
        With ThisWorkbook.Worksheets("WBS_Hours")
            .Rows("2:" & .Rows.Count).Delete
        End With
         
         
         'If you want to start with a blank summary sheet, uncomment the next paragraph
        With SummarySheet
             'Clear all rows below the column header
            SummarySheetLastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
            If SummarySheetLastRow > 2 Then
                .Range("A2:A" & SummarySheetLastRow).EntireRow.Delete
            End If
        End With
         
         
         ' Loop through the list of returned file names
        For NFile = LBound(SelectedFiles) To UBound(SelectedFiles) ' ---FIRST LOOP START ---+
             
             ' Set FileName to be the current workbook file name to open.
            Filename = SelectedFiles(NFile)
            FName = Mid(Filename, InStrRev(Filename, "\") + 1, 999)
             
             ' Open the next workbook that was selected in the dialog box
            Set WorkBk = Workbooks.Open(Filename) 'newly opened workbook is Active Workbook
             
             ' Search for specified format Worksheet's Name
            For Each wks In WorkBk.Worksheets ' --- SECOND LOOP START---+
                strSheetName = wks.Name
                 
                 ' Check if Sheet Name format match criteria
                If Len(strSheetName) <> 6 Then GoTo LabNextSheet
                arr = Split(strSheetName, ".")
                If UBound(arr) <> 1 Then GoTo LabNextSheet
                If Not IsNumeric(arr(0)) Then GoTo LabNextSheet
                If Not IsNumeric(arr(1)) Then GoTo LabNextSheet
                If Not Len(arr(0)) = 2 Then GoTo LabNextSheet
                Application.StatusBar = _
                "Processing '" & NFile & "' - '" & strSheetName
                 
                 'Complete WBS_MTL worksheet
                With ThisWorkbook.Worksheets("WBS_MTL")
                    Set FirstBlankCll = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
                End With
                With FirstBlankCll.Resize(5, 1)
                     'Column A - Filename
                    .Offset(0, 0).Value = FName
                     'Column B - WBS Number
                    .Offset(0, 2).Formula = "=HYPERLINK(""" & Filename & "#" & strSheetName & "!N8"",""" & strSheetName & """" & ")"
                     'Column D - Assembly
                    .Offset(0, 3).Value = wks.Range("I10").Value
                     'Column E - Operation Description
                    .Offset(0, 4).Value = wks.Range("H11").Value
                     'Column G - Description
                    .Offset(0, 6).Value = wks.Range("B15:b19").Value
                     'Column H - UM (each or lot)
                    .Offset(0, 7).Value = wks.Range("C15:c19").Value
                     'Column I - Qty
                    .Offset(0, 8).Value = wks.Range("D15:d19").Value
                     'Column J - Cost Each
                    .Offset(0, 9).Value = wks.Range("E15:e19").Value
                     'Column K - Total
                    .Offset(0, 10).Value = wks.Range("R15:r19").Value
                End With
                 
                 'GET HOURS FROM EACH FILE
                 
                With targetWS
                    If IsEmpty(.Range("C2")) Then
                        Set nextAvlbleCllInColA = .Range("a2")
                    Else
                         '### Is column C always populated for every row?
                         '(if not, we should use a different approach to identifying the next row)
                        Set nextAvlbleCllInColA = .Cells(.Range("C1").End(xlDown).Row + 1, "a")
                    End If
                End With
                 
                With wks.Range("F23:Q38")
                     '###RB: is this what you want for columns A & B?
                    nextAvlbleCllInColA.Resize(.Rows.Count, 1).Value2 = FName
                    nextAvlbleCllInColA.Offset(0, 1).Resize(.Rows.Count, 1).Value2 = wks.Name
                     'put the column E value into column C
                    nextAvlbleCllInColA.Offset(0, 2).Resize(.Rows.Count, 1).Value2 = .Offset(0, -1).Resize(.Rows.Count, 1).Value2
                     'to choose the correct column to copy the data into, add 3 to the value of cell F22.
                    nextAvlbleCllInColA.Offset(0, wks.Range("F22").Value2 + 2).Resize(.Rows.Count, .Columns.Count).Value2 = .Value2
                End With
                 
                 '     Go on to the next loop
LabNextSheet:
            Next wks ' --- SECOND LOOP END ---+
             
            WorkBk.Close savechanges:=False
        Next NFile ' --- FIRST LOOP END ---+
         
         'RB: moved out of the loop because it only needs to be done once.
        SummarySheet.Columns.AutoFit
    End If
    
    delete_Blank_Rows
     
     'Reset app. settings
    With Application
        .StatusBar = False
        .ScreenUpdating = True
        .displayAlerts = False
        .EnableEvents = True
    End With
     
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,109,033
Messages
5,526,363
Members
409,697
Latest member
christopherlewis1620

This Week's Hot Topics

Top