Change Macro to import files from hyperlinks

[GarnesGambit]

Hi all,

I'm new to Macros and learning as I go! I have a great Macro (I found online) that allows me to select a folder and it will import all excel files in this folder and consolidate into one worksheet.

I'm wondering, would it be possible to edit this macro to instead of take files from a folder on my desktop, I can select multiple hyperlinks in my workbook and open/ consolidate those? Example I could select multiple cells in column J of my workbook (this column contains the individual files) and run this code to consolidate?

Essentially I have a master file, where each of my files are hyperlinked and linked to specific stores (some plans are unique, others can belong to multiple stores). The struggle I have is all plans are in 1 folder just now as it's not sustainable to have to save them multiple times in multiple folders by store.

Code below:

Sub ImportFiles()
Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, FileName As String
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
Dim FolderPath As String, fldr As FileDialog, Lr As Long, Lc As Long, Lr2 As Long
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
Debug.Print DestSheet.Name
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
   FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
xStrName = Sh1.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = xStrName Then
Lr = DestSheet.Range("C" & Rows.Count).End(xlUp).Row
Lr2 = xWS.Range("C" & Rows.Count).End(xlUp).Row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
If Lr = 1 Then
Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("C1")
Else
Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("C" & Lr + 1)
End If
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub

Appreciate all help in advance!

 

[John_w]

This macro shows how to loop through the selected cells and, if the cell contains a hyperlink, open that workbook.

Public Sub Open_Selected_Hyperlinks()

    Dim cell As Range
    
    For Each cell In Selection
        If cell.Hyperlinks.Count > 0 Then
            Workbooks.Open cell.Hyperlinks(1).Address, ReadOnly:=True
        End If
    Next

End Sub

After the above Workbooks.Open, insert your code from xStrAWBName = ActiveWorkbook.Name to Workbooks(xStrAWBName).Close.

 

[GarnesGambit]

This macro shows how to loop through the selected cells and, if the cell contains a hyperlink, open that workbook.

Public Sub Open_Selected_Hyperlinks()

    Dim cell As Range
   
    For Each cell In Selection
        If cell.Hyperlinks.Count > 0 Then
            Workbooks.Open cell.Hyperlinks(1).Address, ReadOnly:=True
        End If
    Next

End Sub

After the above Workbooks.Open, insert your code from xStrAWBName = ActiveWorkbook.Name to Workbooks(xStrAWBName).Close.

Hi John, appreciate your help on this one! Unfortunately when I've amended as you've mentioned above it doesn't actually run anything (no Errors). Perhaps I've typed incorrectly:

Public Sub Open_Selected_Hyperlinks()

    Dim cell As Range
    
    For Each cell In Selection
        If cell.Hyperlinks.Count > 0 Then
            Workbooks.Open cell.Hyperlinks(1).Address, ReadOnly:=True
            xStrAWBName = ActiveWorkbook.Name
Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
xStrName = Sh1.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = xStrName Then
Lr = DestSheet.Range("C" & Rows.Count).End(xlUp).Row
Lr2 = xWS.Range("C" & Rows.Count).End(xlUp).Row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
If Lr = 1 Then
Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("C1")
Else
Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("C" & Lr + 1)
End If
End If
Next xWS
Workbooks(xStrAWBName).Close
        End If
    Next

End Sub

 

[GarnesGambit]

John, I believe my error is I need to change the code to not attempt to open the hyperlinks in the active workbook, but another "Master" file.

So I have the workbook with my hyperlinks, I need to be able to select the ones I need there, run the macro, and have it consolidate them in a different workbook?

 

[GarnesGambit]

I'm now getting a runtime error 1004, it's telling me it cannot find the file it's looking for, but the hyperlink absolutely does exist and opens fine on it's own?

Highlighting the below part of the code (which is the part looking for the file)

Workbooks.Open cell.Hyperlinks(1).Address, ReadOnly:=True

 

[John_w]

First, what type of hyperlinks are they? Inserted via the Insert Link dialogue or =HYPERLINK formulas? The code expects the former.

I believe my error is I need to change the code to not attempt to open the hyperlinks in the active workbook, but another "Master" file.

So I have the workbook with my hyperlinks, I need to be able to select the ones I need there, run the macro, and have it consolidate them in a different workbook?

That doesn't really make sense to me. If you select the hyperlinks in the "Master" workbook that becomes the active workbook and the For Each cell In Selection in the code should loop through the selected cells. With the hyperlinks selected in the "Master" workbook and that workbook active, you would run the Open_Selected_Hyperlinks macro in the macro workbook (.xlsm file).

 

[GarnesGambit]

Hi John, appreciate your feedback. They are hyperlinks created by the =hyperlink formula. I am attempting to work the macro in a practise sheet with the former though.

When I run it now, it gives me a runtime error 424, object required for the below part of the code. It's only opening the first file in the selection

Lr = DestSheet.Range("C" & Rows.Count).End(xlUp).Row

 

[John_w]

So I have the workbook with my hyperlinks, I need to be able to select the ones I need there, run the macro, and have it consolidate them in a different workbook?

Returning to your above quote, my understanding is that 3 workbooks are involved:

1. The workbook containing hyperlinks.
2. The consolidation workbook.
3. The macro workbook (.xlsm file).

Put the code below in the macro workbook.

The code contains the full names of workbook 1 and workbook 2 and opens them if they aren't already open. It then activates workbook 1 and prompts you to select the hyperlink cells. If OK is clicked it loops through the selected cells and copies the cells from "Sheet1" in the hyperlinked workbooks to "Sheet1" in the consolidation workbook.

Note - only "Sheet1" is copied because in your OP you have this code:

Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
xStrName = Sh1.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = xStrName Then

i.e. your code is looping through all the sheets and if the sheet name is "Sheet1" then copy the cells from it.

Public Sub Combine_Hyperlinked_Workbooks()

    Dim HyperlinksWb As Workbook, ConsolidationWb As Workbook
    Dim Wb As Workbook, sourceWs As Worksheet
    Dim ConsolidationSheet As Worksheet
    Dim selectedCells As Range, cell As Range
    Dim linkAddress As String
    Dim lrDest As Long, lrSource As Long, lcSource As Long
   
    'Open the workbook containing hyperlinks
   
    Set HyperlinksWb = Workbooks.Open("C:\folder\path\HYPERLINKS WORKBOOK.xlsx")    'CHANGE THIS
   
    'Open the consolidation workbook.  Data from the hyperlinked workbooks will be copied to "Sheet1" in this workbook
   
    Set ConsolidationWb = Workbooks.Open("C:\folder\path\CONSOLIDATION WORKBOOK.xlsx")     'CHANGE THIS
    Set ConsolidationSheet = ConsolidationWb.Worksheets("Sheet1")
       
    'Prompt user to select hyperlink cells

    HyperlinksWb.Activate  
    On Error Resume Next
    Set selectedCells = Application.InputBox("Select the cells in '" & HyperlinksWb.Name & "' containing hyperlinks and click OK to continue", "Select hyperlink cells", Type:=8)
    On Error GoTo 0
    If selectedCells Is Nothing Then
        'User cancelled
        Exit Sub
    End If

    'Loop through selected cells
   
    For Each cell In selectedCells
   
        linkAddress = GetHyperlinkLocation(cell)

        If linkAddress <> "" Then
            'Open the hyperlinked workbook
            Set Wb = Workbooks.Open(linkAddress, ReadOnly:=True)
           
            Set sourceWs = Nothing
            On Error Resume Next
            Set sourceWs = Wb.Worksheets("Sheet1")
            On Error GoTo 0
           
            If Not sourceWs Is Nothing Then
                'Copy from "Sheet1" in the hyperlinked workbook to the Consolidation workbook
                With sourceWs
                    lrDest = ConsolidationSheet.Range("C" & Rows.Count).End(xlUp).Row
                    lrSource = .Range("C" & .Rows.Count).End(xlUp).Row
                    lcSource = .Cells(1, .Columns.Count).End(xlToLeft).Column
                    If lrDest = 1 Then
                        .Range(.Cells(1, 1), .Cells(lrSource, lcSource)).Copy ConsolidationSheet.Range("C1")
                    Else
                        .Range(.Cells(2, 1), .Cells(lrSource, lcSource)).Copy ConsolidationSheet.Range("C" & lrDest + 1)
                    End If
                End With
            End If
           
            Wb.Close False
       
        End If
       
    Next

    ConsolidationWb.Save
   
    HyperlinksWb.Close False
   
End Sub


'Get hyperlink address from the specified cell.  The cell can contain either a HYPERLINK formula (can parse simple formulas) or a link inserted by Insert -> Link
Private Function GetHyperlinkLocation(cell As Range) As String

    Dim p1 As Long, p2 As Long
    
    With cell.Item(1, 1)
        If .Hyperlinks.Count = 1 Then
            'The hyperlink was inserted by Insert -> Link
            GetHyperlinkLocation = .Hyperlinks(1).Address
        Else
            p1 = InStr(1, .Formula, "HYPERLINK(", vbTextCompare)
            If p1 > 0 Then
                'The hyperlink is a HYPERLINK formula
                p1 = p1 + Len("HYPERLINK(")
                p2 = InStr(p1, .Formula, ",")
                If p2 > 0 Then
                    GetHyperlinkLocation = Evaluate(Mid(.Formula, p1, p2 - p1))
                End If
            Else
                'The cell doesn't contain a hyperlink
                GetHyperlinkLocation = ""
            End If
        End If
    End With
    
End Function

They are hyperlinks created by the =hyperlink formula. I am attempting to work the macro in a practise sheet with the former though.

OK, understood. The macro above should work with both types of hyperlink, though it can parse only fairly simple =HYPERLINK formulas.

 

[GarnesGambit]

Hi John, thanks again for taking the time to explain! I appreciate it massively.

Adding the above code works to the point of allowing me to select the hyperlinks, but then I get a a Dynamic Data Exchange message (I've never had this before so not too sure what it does?)

Clicking all 3 options ends in nothing else happening- perhaps it's my settings?

Image attached of the DDE message.

 

[GarnesGambit]

For an update John, I added the code

Private Sub Workbook_Open()
ActiveWorkbook.EnableConnections
Application.DisplayAlerts = False
End Sub

Which removes the DDE message, but still no data transfers into the consolidated workbook.