SQL VBA Query to pull data from Excel sheet in same format

[Gauraw]

Hi Everyone,

Have written code to pull data from one excel sheet to another using SQL VBA Query. The user interface has multiple filters (combo box) to filter data from the source excel sheet (serving as database). UI and database sheet are in same workbook.Everything thing is working fine apart from one thing . The data that is getting pulled/filtered is getting pasted as values/text format, The need is that the data should get filtered in the same format as Source sheet (Database).

Here is the piece of code that is written :

Private Sub cmdShowData_Click()


Application.ScreenUpdating = False


    'populate data
    strSQL = "SELECT [Tilte],[Body],[Source],[Published Date] FROM [Database$] WHERE "
    If ComboBox1.Text <> "" Then
        strSQL = strSQL & " [Geography]='" & ComboBox1.Text & "'"
    End If
    
    If ComboBox2.Text <> "" Then
        If ComboBox1.Text <> "" Then
            strSQL = strSQL & " AND [Therapy Area]='" & ComboBox2.Text & "'"
        Else
            strSQL = strSQL & " [Therapy Area]='" & ComboBox2.Text & "'"
        End If
    End If


    If ComboBox3.Text <> "" Then
        If ComboBox1.Text <> "" Or ComboBox2.Text <> "" Then
            strSQL = strSQL & " AND [Indication]='" & ComboBox3.Text & "'"
        Else
            strSQL = strSQL & " [Indication]='" & ComboBox3.Text & "'"
        End If
    End If
    
    If ComboBox4.Text <> "" Then
        If ComboBox1.Text <> "" Or ComboBox2.Text <> "" Or ComboBox3.Text <> "" Then
            strSQL = strSQL & " AND [Company]='" & ComboBox4.Text & "'"
        Else
            strSQL = strSQL & " [Company]='" & ComboBox4.Text & "'"
        End If
    End If
    
    If ComboBox5.Text <> "" Then
        If ComboBox1.Text <> "" Or ComboBox2.Text <> "" Or ComboBox3.Text <> "" Or ComboBox4.Text <> "" Then
            strSQL = strSQL & " AND [News Category]='" & ComboBox5.Text & "'"
        Else
            strSQL = strSQL & " [News Category]='" & ComboBox5.Text & "'"
        End If
    End If
    
    
    
    If ComboBox1.Text <> "" Or ComboBox2.Text <> "" Or ComboBox3.Text <> "" Or ComboBox4.Text <> "" Or ComboBox5.Text <> "" Then
        'now extract data
        closeRS
        
        OpenDB
        
        rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
        If rs.RecordCount > 0 Then
            Sheets("UI").Visible = True
            Sheets("UI").Select
            Range("dataSet").Select


            Range(Selection, Selection.End(xlDown)).ClearContents
            
            'Now putting the data on the sheet
            ActiveCell.CopyFromRecordset rs      
        


        Else
            MsgBox "No Matching Recoreds Found!.", vbExclamation + vbOKOnly
            Exit Sub
        End If


        
    End If
    
Application.ScreenUpdating = True


End Sub

Kindly suggest me how I Can pull/filter data in same format as of my source excel sheet.

With Regards,
Gauraw

 

[John_w]

Here's one way. Add the following function which returns the cell format of the specified database sheet column.

Private Function GetDatabaseColumnFormat(databaseSheetName As String, columnName As String) As String

    'Search row 1 of specified sheet for specified column name and return format of the found cell, or General if not found
    
    Dim col As Variant
    
    col = Application.Match(columnName, ActiveWorkbook.Worksheets(databaseSheetName).Rows(1), 0)
    
    If Not IsError(col) Then
        'columnName found in row 1 so return format of that cell
        GetDatabaseColumnFormat = ActiveWorkbook.Worksheets(databaseSheetName).Cells(1, col).NumberFormat
    Else
        'columnName not found in row 1 so return General format
        GetDatabaseColumnFormat = "General"
    End If
    'Debug.Print columnName, col, GetDatabaseColumnFormat
    
End Function

Call the function by replacing your CopyFromRecordset line with:

    With ActiveCell
        .CopyFromRecordset rs
        Dim c As Integer
        For c = 0 To rs.Fields.Count - 1
            .Offset(0, c).EntireColumn.NumberFormat = GetDatabaseColumnFormat("Database", rs.Fields(c).Name)
        Next
    End With

 

[Gauraw]

Thank you John for the solution. Your written code works fine for all the columns except one and that column is a HYPERLINK Column. Each record has a column which have url/Hyperlink associate with them. Kindly suggest me how I can retrieve the HYPERLINK as well from Source Sheet (Database).

For E.g.

The column has Hyperlink record as such Google means HYPERLINK("www.google.com","Google").
When anyone clicks in Google, the Google site gets opened.
Currently Google is only getting copied as TEXT.


With Regards,
Gauraw

Here's one way. Add the following function which returns the cell format of the specified database sheet column.

Private Function GetDatabaseColumnFormat(databaseSheetName As String, columnName As String) As String

    'Search row 1 of specified sheet for specified column name and return format of the found cell, or General if not found
    
    Dim col As Variant
    
    col = Application.Match(columnName, ActiveWorkbook.Worksheets(databaseSheetName).Rows(1), 0)
    
    If Not IsError(col) Then
        'columnName found in row 1 so return format of that cell
        GetDatabaseColumnFormat = ActiveWorkbook.Worksheets(databaseSheetName).Cells(1, col).NumberFormat
    Else
        'columnName not found in row 1 so return General format
        GetDatabaseColumnFormat = "General"
    End If
    'Debug.Print columnName, col, GetDatabaseColumnFormat
    
End Function

Call the function by replacing your CopyFromRecordset line with:

    With ActiveCell
        .CopyFromRecordset rs
        Dim c As Integer
        For c = 0 To rs.Fields.Count - 1
            .Offset(0, c).EntireColumn.NumberFormat = GetDatabaseColumnFormat("Database", rs.Fields(c).Name)
        Next
    End With

 

[John_w]

To retrieve a HYPERLINK formula from a database sheet cell (record/row r, field/column c), rather than the plain hyperlink value, you have to get the cell's Formula property by directly referencing the cell. This means looping through the recordset record by record and the fields one by one and writing the results to the destination sheet, rather than using CopyFromRecordset to write the results in one operation.

See if you can incorporate the following code into your code. It includes the ADODB Connection and Recordset objects which you may need to change. It uses the strSQL string containing your SQL SELECT query, so the code should be inserted/called after this string is defined.

Public Sub Retrieve_Records()

    Dim strSQL As String
    Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
    Dim destCell As Range
    Dim r As Long, c As Long
    Dim recordNum As Long
    Dim databaseCell As Range
    
    strSQL = "Your SQL SELECT string"
    
    With Worksheets("UI")
        .Visible = True
        .Select
        .Range("dataSet").ClearContents
        Set destCell = .Range("dataSet")
    End With
    
    Set dbConnection = New ADODB.Connection
    With dbConnection
        .ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};ReadOnly=1;DBQ=" & ActiveWorkbook.FullName
        .Open
    End With

    Set rs = New ADODB.Recordset
    With rs
       .CursorLocation = adUseClient
       .CursorType = adOpenStatic               'required to get rs.Bookmark
       .LockType = adLockBatchOptimistic
       .ActiveConnection = dbConnection
       .Open strSQL
    End With
    
    'Put bold field names in row 1
    
    For c = 0 To rs.Fields.Count - 1
        destCell.Offset(0, c).Value = rs.Fields(c).Name
    Next
    destCell.Resize(1, rs.Fields.Count).Font.Bold = True
    
    'Loop through each record in the recordset
    
    recordNum = 1
    rs.MoveFirst
    Do Until rs.EOF
        
        'Loop through fields (columns) in this record
        
        For c = 0 To rs.Fields.Count - 1

            'Get database cell of this record/field combination

            Set databaseCell = GetDatabaseCell("Database", rs.Fields(c).Name, rs.Bookmark + 1)
            If InStr(1, databaseCell.Formula, "HYPERLINK(", vbTextCompare) Then
                'Cell contains a HYPERLINK formula, so put formula in result cell
                destCell.Offset(recordNum, c).Formula = databaseCell.Formula
            Else
                'Cell doesn't contain a HYPERLINK formula, so put field value in result cell
                destCell.Offset(recordNum, c).Value = rs.Fields(c).Value
            End If

        Next
        
        'Get next record
        
        rs.MoveNext
        recordNum = recordNum + 1
        
    Loop
      
    'Set format of each result column to same as corresponding database sheet column
    
    With destCell
        For c = 0 To rs.Fields.Count - 1
            .Offset(0, c).EntireColumn.NumberFormat = GetDatabaseColumnFormat("Database", rs.Fields(c).Name)
        Next
    End With

    rs.Close
    dbConnection.Close
    
    Set rs = Nothing
    Set dbConnection = Nothing
    
End Sub


Private Function GetDatabaseCell(databaseSheetName As String, columnName As String, rowNumber As Long) As Range

    Dim colNumber As Variant
    
    'Search row 1 of specified sheet for specified column name and get column number of the found cell
    
    colNumber = Application.Match(columnName, ActiveWorkbook.Worksheets(databaseSheetName).Rows(1), 0)
    
    If Not IsError(colNumber) Then
        'columnName found in row 1 so return cell of specified database row
        Set GetDatabaseCell = ActiveWorkbook.Worksheets(databaseSheetName).Cells(rowNumber, colNumber)
    Else
        'columnName not found in row 1 so return Nothing
        Set GetDatabaseCell = Nothing
    End If
    
End Function


Private Function GetDatabaseColumnFormat(databaseSheetName As String, columnName As String) As String

    'Search row 1 of specified sheet for specified column name and return format of the found cell, or General if not found
    
    Dim col As Variant
    
    col = Application.Match(columnName, ActiveWorkbook.Worksheets(databaseSheetName).Rows(1), 0)
    
    If Not IsError(col) Then
        'columnName found in row 1 so return format of that cell
        GetDatabaseColumnFormat = ActiveWorkbook.Worksheets(databaseSheetName).Cells(1, col).NumberFormat
    Else
        'columnName not found in row 1 so return General format
        GetDatabaseColumnFormat = "General"
    End If
    
End Function

 

[Gauraw]

Thanks a bunch John_w for suggesting me all the codes and helping me to solve my problem.

Thanks Again!