VBA code to pull over a specific value in 300+ different sheets

[dwalls]

I have a workbook that has 300+ hyperlinks with different information. I have used the hyperlink function, and I am now wanting to pull over a specific value from each hyperlink into a new column. There has to be a way to input a VBA code to get all 300+ values without going in 1 by 1. Attached is the table & macro I had recorded. I utilized the record macro to obtain the value of 2 for Jane Doe. I am wanting to repeat these steps ~300+ more times except I want "Bob" and Bill's values to pull over. Hope this makes sense. Hoping somebody has an easier solution than manually opening each hyperlink to select the specific cell I need information from.

 

[Jeffrey Mahoney]

I hope this gets you started on a new method. The TestGetData shows you how to call the GetData Sub. I added code to get the hyperlink address from cell. You can get any size range you want from a closed workbook and it's fast. You don't have to open the workbook and close it. Ask any question - Jeff

The range reference on the GetData line needs to be "I6:I6" if you only need one cell. You can also add named ranges instead of cell references. I'm not sure if you can use dynamic namged ranges.

Sub TestGetData()
  Dim TargetRng As Range
  Dim PathFile As Variant
 
  PathFile = Sheets("Sheet5").Range("H1").Hyperlinks(1).Address
  Set TargetRng = Sheets("Sheet5").Range("A3")
 
  GetData PathFile, "Day 1", "I6:I6", TargetRng, False, False
End Sub


Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)

    Dim rsCon As Object, rsData As Object, szConnect As String, szSQL As String, lCount As Long

    If Header = False Then
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        End If
    Else
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes"";"
        End If
    End If

    If SourceSheet = "" Then
        ' workbook level name
        szSQL = "SELECT * FROM " & SourceRange$ & ";"
    Else
        ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If

    On Error GoTo SomethingWentWrong

    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")

    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1

    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then

        If Header = False Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount = 0 To rsData.Fields.Count - 1
                    TargetRange.Cells(1, 1 + lCount).Value = _
                    rsData.Fields(lCount).Name
                Next lCount
                TargetRange.Cells(2, 1).CopyFromRecordset rsData
            Else
                TargetRange.Cells(1, 1).CopyFromRecordset rsData
            End If
        End If

    Else
        MsgBox "No records returned from : " & SourceFile, vbCritical
    End If

    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing
    Exit Sub

SomethingWentWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, vbExclamation, "Error"
    On Error GoTo 0

End Sub