getting hyperlink from database to a sheet in excel

Question

I am new to excel ..... well i have 2 excel sheets one as a database and another to display the result based on some selection

enter code here
//for database connectivity

Option Explicit
Public cnn As New ADODB.Connection
Public rs As New ADODB.Recordset
Public strSQL As String

Public Sub OpenDB()
If cnn.State = adStateOpen Then cnn.Close
cnn.ConnectionString =
"Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & _
ActiveWorkbook.Path & Application.PathSeparator & ActiveWorkbook.Name
cnn.Open
End Sub

Public Sub closeRS()
If rs.State = adStateOpen Then rs.Close
rs.CursorLocation = adUseClient
End Sub


// code to display on another sheet
Private Sub cmdReset_Click()
'clear the data
ComboBox1.Clear
ComboBox2.Clear
ComboBox3.Clear
Sheets("View").Visible = True
Sheets("View").Select
Range("dataSet").Select
Range(Selection, Selection.End(xlDown)).ClearContents
End Sub

Private Sub cmdShowData_Click()
'populate data
strSQL = "SELECT * FROM [data$] WHERE "
If ComboBox1.Text <> "" Then
strSQL = strSQL & " [Product]='" & ComboBox1.Text & "'"
End If

If ComboBox2.Text <> "" Then
If ComboBox1.Text <> "" Then
strSQL = strSQL & " AND [Region]='" & ComboBox2.Text & "'"
Else
strSQL = strSQL & " [Region]='" & ComboBox2.Text & "'"
End If
End If

If ComboBox3.Text <> "" Then
If ComboBox1.Text <> "" Or ComboBox2.Text <> "" Then
strSQL = strSQL & " AND [Customer Type]='" & ComboBox3.Text & "'"
Else
strSQL = strSQL & " [Customer Type]='" & ComboBox3.Text & "'"
End If
End If

If ComboBox1.Text <> "" Or ComboBox2.Text <> "" Or ComboBox3.Text <> "" Then
'now extract data
closeRS
OpenDB
rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Sheets("View").Visible = True
Sheets("View").Select
Range("dataSet").Select
Range(Selection, Selection.End(xlDown)).ClearContents
'Now putting the data on the sheet
ActiveCell.CopyFromRecordset rs
Else
MsgBox"I was not able to find any matching records.",vbExclamation+ vbOKOnly
Exit Sub
End If
closeRS
OpenDB

rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Range("L6").CopyFromRecordset rs
Else
Range("L6:M7").Clear
MsgBox "There was some issue getting the totals.", vbExclamation + vbOKOnly
Exit Sub
End If
End If
End If
End Sub
Private Sub ComboBox1_DropButtonClick()
Dim v, e
With Sheets("data").Range("b2:b15")
v = .Value
End With
With CreateObject("scripting.dictionary")
.comparemode = 1
For Each e In v
    If Not .exists(e) Then .Add e, Nothing
Next
If .Count Then Me.ComboBox1.List = Application.Transpose(.keys)
End With
End Sub

Private Sub ComboBox2_DropButtonClick()
Dim v, e
With Sheets("data").Range("c2:c15")
v = .Value
End With
With CreateObject("scripting.dictionary")
.comparemode = 1
For Each e In v
    If Not .exists(e) Then .Add e, Nothing
Next
If .Count Then Me.ComboBox2.List = Application.Transpose(.keys)
End With
End Sub

Private Sub ComboBox3_DropButtonClick()
Dim v, e
With Sheets("data").Range("d2:d15")
v = .Value
End With
With CreateObject("scripting.dictionary")
.comparemode = 1
For Each e In v
If Not .exists(e) Then .Add e, Nothing
Next
If .Count Then Me.ComboBox3.List = Application.Transpose(.keys)
End With
End Sub

and snapshot to get better view [displaying sheet][1] [1]: http://i.stack.imgur.com/pWBoJ.jpg [input sheet with hyperlinks][2] [2]: http://i.stack.imgur.com/lYF3K.jpg now the problem is I want to create a hyperlink on input sheet so that when the data is displayed in output sheet the hyperlink also displayed

also these 2 sheets are in same workbook Thanks everyone in advance

user3598756 user3598756 · Accepted Answer · 2016-03-27T09:17:52

edited after further explanation of OP about hyperlinks

as for your very question ("How to create a hyperlink on input sheet") you just have to copy web addresses from any source (web browser, list,...), paste them in your data sheet proper column and assure that "dataSet" range in "View" sheet is wide enough to enclose this column (from screenshots it would likely be some "Sheets("View").Range("A2:E2")")

besides that I must admit I didn't know about the existence of this ADODB connection (and many others, as now I got to know) to handle worksheet data. So I studied your code and came up to one of its possible refactorings that I hope you don't mind I'm posting here

Option Explicit

'they all seem like module level variables -> no need to declare them "Public"
Dim cnn As New ADODB.Connection
Dim rs As New ADODB.Recordset

' some more useful module level variables
Dim viewSht As Worksheet, dataSht As Worksheet
Dim dataSetRng As Range


Private Sub UserForm_Initialize()

'set module level variables -> they'll be used throughout this module by other subs/funcs
Set viewSht = Sheets("View")
Set dataSht = Sheets("Data")
Set dataSetRng = viewSht.Range("dataSet")

'fill comboboxes -> no need to fill them everytime you click a combobox
Call FillComboBox(Me.ComboBox1, dataSht.Range("b2:b15"))
Call FillComboBox(Me.ComboBox2, dataSht.Range("c2:c15"))
Call FillComboBox(Me.ComboBox3, dataSht.Range("d2:d15"))

viewSht.Activate '<<<== activate your view sheet once for all

End Sub


' code to display on another sheet
Private Sub cmdReset_Click()

Range(dataSetRng, dataSetRng.End(xlDown)).ClearContents

End Sub


Private Sub cmdShowData_Click()
Dim strSQL As String

'populate data

'build strSQL
Call SetStrSQL(strSQL, ComboBox1.text, "Product")
Call SetStrSQL(strSQL, ComboBox2.text, "Region")
Call SetStrSQL(strSQL, ComboBox3.text, "Customer Type")

'try and write data only if strSQL has been built
If Len(strSQL) >= 0 Then
    strSQL = "SELECT * FROM [data$] WHERE " & strSQL
    'now extract data
    closeRS
    OpenDB
    rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
    If rs.RecordCount > 0 Then
        With dataSetRng
            Range(.Cells, .End(xlDown)).ClearContents
            'Now putting the data on the sheet
            .CopyFromRecordset rs
            Call SetHyperLink(.CurrentRegion.Columns(5))
            .EntireColumn.AutoFit
        End With
    Else
        MsgBox "I was not able to find any matching records.", vbExclamation + vbOKOnly
        Exit Sub
    End If
    closeRS
End If

End Sub


Public Sub SetHyperLink(rng As Range)
Dim cell As Range
For Each cell In rng.Offset(1).SpecialCells(xlCellTypeConstants)
   rng.Parent.Hyperlinks.Add cell, cell.Value, , , cell.Value
Next cell
End Sub


Private Sub SetStrSQL(strSQL As String, cbText As String, field As String)

If cbText <> "" Then strSQL = strSQL & IIf(Len(strSQL) = 0, "", " AND") & " [" & field & "]='" & cbText & "'"

End Sub


Private Sub FillComboBox(Cb As ComboBox, dataRng As Range)
Dim v, e

v = dataRng.Value
With CreateObject("scripting.dictionary")
    .CompareMode = 1

    'instead of checking for every element in dictionary, it's faster to try and add element: duplicates will be automatically discharged
    On Error Resume Next '<<< to prevent possible errors thrown by duplicates from stopping the macro
    For Each e In v
        .Add e, Nothing
    Next
    On Error GoTo 0 ' <<< enable error trapping

    If .Count Then Cb.list = Application.Transpose(.Keys)
End With

End Sub
'-------------------------------


'-------------------------------
'ADODB handling code
' as for this block of code I'm just learning from you it exists
' I feel like it could be enhanced but don't know how

Private Sub OpenDB()

CloseDB
cnn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & _
ActiveWorkbook.Path & Application.PathSeparator & ActiveWorkbook.Name
cnn.Open

End Sub


Private Sub CloseDB()

If cnn.State = adStateOpen Then cnn.Close

End Sub


Private Sub closeRS()

If rs.State = adStateOpen Then rs.Close
rs.CursorLocation = adUseClient

End Sub

I see it gets visualized with quite strange an editing, but I don't know how to fix it!

getting hyperlink from database to a sheet in excel

1 Answers