none
Export recordset to Excel Hyperlinks creating a second workbook RRS feed

  • Question

  • Hello,

    First time trying this.

    Exporting a DAO.recordset into a formatted Excel file. Everything works except when I try to format the hyperlinks in a specific column. What happens is that the workbook is created, but when the hyperlinks are added, a second hidden workbook is created. The first workbook has all the data but no hyperlinks, but the second workbook (i.e. Book1) has all the data plus the hyperlinks. The hyperlinks are all in Column 36.

    Here is some of the code:

        Set objExcelApp = CreateObject("Excel.Application")
        objExcelApp.Visible = False
        Set objExcelWkb = objExcelApp.Workbooks.Add
        Set objExcelSheet = objExcelApp.Worksheets(1)

        With objExcelSheet
            .Name = "Data Request"
            .Cells.Font.Name = "Calibri"
            .Cells.Font.Size = 12

    'column headings

            For cols = 0 To rs.Fields.Count - 1
                    .Cells(1, cols + 1).Value = rs.Fields(cols).Name
            Next       

    'set price column in currency format
            .Columns("AD").NumberFormat = "$#,##0.00;-$#,##0.00"

    'fill in the data starting at A2
            .Range("A2").CopyFromRecordset rs

            

    'format hyperlinks

            For lngRow = 2 To ActiveCell.SpecialCells(xlLastCell).Row
                Set ranCell = Cells(lngRow, 36)
                If Left(ranCell, 8) = "https://" Then
                    Call ActiveSheet.Hyperlinks.Add(Anchor:=ranCell, Address:=ranCell, TextToDisplay:=ranCell.text)
                End If
            Next lngRow

        End With

        rs.Close
        objExcelWkb.SaveAs (strPath)

    Thank you for any help.

    Albert

    Monday, March 30, 2020 9:28 PM

Answers

  • The following works fine for me

        Dim objExcelApp           As Object
        Dim objExcelWkb           As Object
        Dim objExcelSheet         As Object
        Dim rs                    As DAO.Recordset
        Dim cols                  As Integer
        Dim lngRow                As Long
        Dim ranCell               As Object
        Const xlLastCell = 11
        Const strPath = "C:\temp\testing01.xlsx"
    
        Set rs = CurrentDb.OpenRecordset("urls")
    
        Set objExcelApp = CreateObject("Excel.Application")
        objExcelApp.Visible = False
        Set objExcelWkb = objExcelApp.Workbooks.Add
        Set objExcelSheet = objExcelApp.Worksheets(1)
    
        With objExcelSheet
            .Name = "Data Request"
            .cells.Font.Name = "Calibri"
            .cells.Font.Size = 12
    
            'column headings
            For cols = 0 To rs.Fields.Count - 1
                .cells(1, cols + 1).Value = rs.Fields(cols).Name
            Next
    
            'set price column in currency format
            .Columns("AD").NumberFormat = "$#,##0.00;-$#,##0.00"
    
            'fill in the data starting at A2
            .Range("A2").CopyFromRecordset rs
    
            'format hyperlinks
            For lngRow = 2 To objExcelApp.ActiveCell.SpecialCells(xlLastCell).Row
                Set ranCell = objExcelSheet.cells(lngRow, 3)
                If Left(ranCell, 8) = "https://" Then
                    Call objExcelApp.ActiveSheet.Hyperlinks.Add(Anchor:=ranCell, Address:=ranCell, TextToDisplay:=ranCell.text)
                End If
            Next lngRow
    
        End With
        rs.Close
        objExcelWkb.SaveAs (strPath) '(1) What about file conflicts? ***
        '(2) Don't forget the either close Excel or make it visible to the user,
        '   otherwise you will be leaving a hidden running instance. ***
    
        Set rs = Nothing
        Set ranCell = Nothing
        Set objExcelSheet = Nothing
        Set objExcelWkb = Nothing
        Set objExcelApp = Nothing

     

    You could, to simplify your code, also replace

    Call objExcelApp.ActiveSheet.Hyperlinks.Add(Anchor:=ranCell, Address:=ranCell, TextToDisplay:=ranCell.text)
    with
    Call .Hyperlinks.Add(Anchor:=ranCell, Address:=ranCell, TextToDisplay:=ranCell.text)
    because you are already within an objExcelSheet with statement


    Daniel Pineault, 2010-2019 Microsoft MVP
    Professional Support: http://www.cardaconsultants.com
    MS Access Tips and Code Samples: http://www.devhut.net


    Tuesday, March 31, 2020 10:49 AM

All replies

  • When asking questions, it truly helps us if you provide your full procedure this way we see declarations, error handling, ... all these things can impact functionality.

    Daniel Pineault, 2010-2019 Microsoft MVP
    Professional Support: http://www.cardaconsultants.com
    MS Access Tips and Code Samples: http://www.devhut.net

    Tuesday, March 31, 2020 10:35 AM
  • The following works fine for me

        Dim objExcelApp           As Object
        Dim objExcelWkb           As Object
        Dim objExcelSheet         As Object
        Dim rs                    As DAO.Recordset
        Dim cols                  As Integer
        Dim lngRow                As Long
        Dim ranCell               As Object
        Const xlLastCell = 11
        Const strPath = "C:\temp\testing01.xlsx"
    
        Set rs = CurrentDb.OpenRecordset("urls")
    
        Set objExcelApp = CreateObject("Excel.Application")
        objExcelApp.Visible = False
        Set objExcelWkb = objExcelApp.Workbooks.Add
        Set objExcelSheet = objExcelApp.Worksheets(1)
    
        With objExcelSheet
            .Name = "Data Request"
            .cells.Font.Name = "Calibri"
            .cells.Font.Size = 12
    
            'column headings
            For cols = 0 To rs.Fields.Count - 1
                .cells(1, cols + 1).Value = rs.Fields(cols).Name
            Next
    
            'set price column in currency format
            .Columns("AD").NumberFormat = "$#,##0.00;-$#,##0.00"
    
            'fill in the data starting at A2
            .Range("A2").CopyFromRecordset rs
    
            'format hyperlinks
            For lngRow = 2 To objExcelApp.ActiveCell.SpecialCells(xlLastCell).Row
                Set ranCell = objExcelSheet.cells(lngRow, 3)
                If Left(ranCell, 8) = "https://" Then
                    Call objExcelApp.ActiveSheet.Hyperlinks.Add(Anchor:=ranCell, Address:=ranCell, TextToDisplay:=ranCell.text)
                End If
            Next lngRow
    
        End With
        rs.Close
        objExcelWkb.SaveAs (strPath) '(1) What about file conflicts? ***
        '(2) Don't forget the either close Excel or make it visible to the user,
        '   otherwise you will be leaving a hidden running instance. ***
    
        Set rs = Nothing
        Set ranCell = Nothing
        Set objExcelSheet = Nothing
        Set objExcelWkb = Nothing
        Set objExcelApp = Nothing

     

    You could, to simplify your code, also replace

    Call objExcelApp.ActiveSheet.Hyperlinks.Add(Anchor:=ranCell, Address:=ranCell, TextToDisplay:=ranCell.text)
    with
    Call .Hyperlinks.Add(Anchor:=ranCell, Address:=ranCell, TextToDisplay:=ranCell.text)
    because you are already within an objExcelSheet with statement


    Daniel Pineault, 2010-2019 Microsoft MVP
    Professional Support: http://www.cardaconsultants.com
    MS Access Tips and Code Samples: http://www.devhut.net


    Tuesday, March 31, 2020 10:49 AM
  • OK, thank you so much. This line seems to have made the difference:

    Set ranCell = objExcelSheet.cells(lngRow, 36)

    Sorry about not posting all the code as it has a number of message boxes about sending the workbook by email or viewing, etc. I also have all the closing statements later on in the procedure.

    Take care,

    Albert

    Tuesday, March 31, 2020 5:38 PM