Solved VBA code to find and replace values in exported Excel spreadsheet with hyperlinks (1 Viewer)

cgala

New member
Local time
Today, 11:31
Joined
Jan 29, 2021
Messages
10
Hi All,

EDIT:

I've now got a functional piece of code that exports a subset of my Access table to an Excel spreadsheet. Within the exported spreadsheet, the code also finds the cells which contain a certain value and replaces this value with a hyperlink.

(I was previously having issues with the hyperlinking, see attachment for original code that didn't work due to the UsedRange).

The problem is that the code uses Activate when looking for the cells to be hyperlinked, which I've since been advised not to use. The code also doesn't set the range of the Workbook dynamically. Full code is below.

The question/s are therefore, how can I change the code to avoid using Activate or Select, and how can I set the range of cells to be searched, dynamically?

Code:
Public Function export_spreadsheet()

    On Error GoTo ErrorHandler

    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim db As DAO.Database
    Dim rs As DAO.Recordset

    Set db = CurrentDb
    Set rs = db.OpenRecordset("qry_chief_people_officer")

    DoCmd.Hourglass (True)

    Set xlApp = CreateObject("Excel.Application")

        With xlApp
            .Visible = False
            .Workbooks.Open _
            ("template.xlsx")
            .ActiveWorkbook.SaveAs ("template " & Format(Now(), "DD-MMM-YY") & ".xlsx")
            .ActiveWorkbook.Close
         
        End With

    Set xlBook = xlApp.Workbooks.Open("template " & Format(Now(), "DD-MMM-YY") & ".xlsx")
    Set xlSheet = xlApp.Worksheets(1)

        With xlSheet
            .Name = "CPO_Records" 'Rename the sheet
              For cols = 0 To rs.Fields.Count - 1
             .Cells(2, cols + 1).Value = rs.Fields(cols).Name
             Next
             .Range("A3").CopyFromRecordset rs 'Copy data from recordsset to sheet
        End With

   'Adding the hyperlinks to the Excel spreadsheet
    Dim firstAddress As String, c As Range, r As Range

        With xlSheet.Range("A1:AJ200") 'Improvement would be to make this dynamic, based on the exported spreadsheet
            Set c = Cells.Find(What:="Click here for further information", LookIn:=xlValues, Lookat:=xlWhole, _
            MatchCase:=False)
         
            If Not c Is Nothing Then
                Set r = c
                firstAddress = c.Address
                Do
                    Set r = Union(r, c)
                    xlSheet.Range(c.Address).Activate
                    Set c = Cells.FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
            .Activate
            If Not r Is Nothing Then r.Select
        End With

          ActiveSheet.hyperlinks.Add Anchor:=r, Address:= _
            "MY-LINK" _
            , TextToDisplay:="Click here for further information"

         With xlApp
        .ActiveWorkbook.Save
        End With

    Set xlBook = Nothing
    Set xlSheet = Nothing

    MsgBox "File saved to your (U:) drive", vbInformation + vbOKOnly, "Export Success"
     
    DoCmd.Hourglass False
    xlApp.Visible = True

ErrorHandler:
    MsgBox "Export unsuccessful." & vbCrLf & vbCrLf & "The following error has occurred: " & Err.Description
    Exit Function

End Function


Cheers
 

Attachments

  • excel_vba_to_access.png
    excel_vba_to_access.png
    49.2 KB · Views: 610
Last edited:

theDBguy

I’m here to help
Staff member
Local time
Today, 04:31
Joined
Oct 29, 2018
Messages
21,358
Hi. Just a thought, but wouldn't it be easier to modify the data while it's still in Access before you export it to Excel, rather than try to do it other way around?
 

cgala

New member
Local time
Today, 11:31
Joined
Jan 29, 2021
Messages
10
Hi. Just a thought, but wouldn't it be easier to modify the data while it's still in Access before you export it to Excel, rather than try to do it other way around?
Hi @theDBguy,

I thought that originally, but the issues is that only a small fraction of the rows in the table/query need the hyperlinks (blame bad database management which I can't change). In Access, I couldn't find a way to only format certain cells/rows in a field as hyperlinks. My impression is that the whole field has to be a hyperlink. Correct me if I'm wrong or if you can think of an Access-led solution.
 

Isaac

Lifelong Learner
Local time
Today, 04:31
Joined
Mar 14, 2017
Messages
8,738
You're setting a worksheet variable to a UsedRange property, which makes no sense whatsoever. It would be like making a car equal to an octopus. Hence the type mismatch error.
 

cgala

New member
Local time
Today, 11:31
Joined
Jan 29, 2021
Messages
10
You're setting a worksheet variable to a UsedRange property, which makes no sense whatsoever. Hence the type mismatch error.
I used this as it worked in the Excel vba to limit the range to only the used cells - the number of columns/rows may change in the export so I wanted it to be dynamic. Please can you suggest what I should be setting this to?
 

Isaac

Lifelong Learner
Local time
Today, 04:31
Joined
Mar 14, 2017
Messages
8,738
I suggest you clean up any extra lines, make your code as easy to look at as possible, and then post all your code - the entire procedure you're trying to use now and having trouble with.

NEVER USE SELECT OR ACTIVATE IN EXCEL VBA. Set variables to appropriate things and act upon them. Don't rely on select or activating anything!
 

cgala

New member
Local time
Today, 11:31
Joined
Jan 29, 2021
Messages
10
I suggest you clean up any extra lines, make your code as easy to look at as possible, and then post all your code - the entire procedure you're trying to use now and having trouble with.

NEVER USE SELECT OR ACTIVATE IN EXCEL VBA. Set variables to appropriate things and act upon them. Don't rely on select or activating anything!
You put me on the right track and I've now got the code to add the hyperlinks working (tidied too), albeit with .Activate used:

Code:
Public Function export_spreadsheet()

    On Error GoTo ErrorHandler
  
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
  
    Set db = CurrentDb
    Set rs = db.OpenRecordset("qry_chief_people_officer")
  
    DoCmd.Hourglass (True)
  
    Set xlApp = CreateObject("Excel.Application")

        With xlApp
            .Visible = False
            .Workbooks.Open _
            ("template.xlsx")
            .ActiveWorkbook.SaveAs ("template " & Format(Now(), "DD-MMM-YY") & ".xlsx")
            .ActiveWorkbook.Close
          
        End With

    Set xlBook = xlApp.Workbooks.Open("template " & Format(Now(), "DD-MMM-YY") & ".xlsx")
    Set xlSheet = xlApp.Worksheets(1)
  
        With xlSheet
            .Name = "CPO_Records" 'Rename the sheet
              For cols = 0 To rs.Fields.Count - 1
             .Cells(2, cols + 1).Value = rs.Fields(cols).Name
             Next
             .Range("A3").CopyFromRecordset rs 'Copy data from recordsset to sheet
        End With
  
   'Adding the hyperlinks to the Excel spreadsheet
    Dim firstAddress As String, c As Range, r As Range
  
        With xlSheet.Range("A1:AJ200") 'Improvement would be to make this dynamic, based on the exported spreadsheet
            Set c = Cells.Find(What:="Click here for further information", LookIn:=xlValues, Lookat:=xlWhole, _
            MatchCase:=False)
          
            If Not c Is Nothing Then
                Set r = c
                firstAddress = c.Address
                Do
                    Set r = Union(r, c)
                    xlSheet.Range(c.Address).Activate
                    Set c = Cells.FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
            .Activate
            If Not r Is Nothing Then r.Select
        End With
  
          ActiveSheet.hyperlinks.Add Anchor:=r, Address:= _
            "MY-LINK" _
            , TextToDisplay:="Click here for further information"

         With xlApp
        .ActiveWorkbook.Save
        End With

    Set xlBook = Nothing
    Set xlSheet = Nothing
  
    MsgBox "File saved to your (U:) drive", vbInformation + vbOKOnly, "Export Success"
      
    DoCmd.Hourglass False
    xlApp.Visible = True

ErrorHandler:
    MsgBox "Export unsuccessful." & vbCrLf & vbCrLf & "The following error has occurred: " & Err.Description
    Exit Function

End Function

I thought I'd post now before I look into changing the .Activate. Any pointers on how to a) make the sheet range selected dynamic, and b) how to redo the code by setting variables would be much appreciated.
 

sxschech

Registered User.
Local time
Today, 04:31
Joined
Mar 2, 2010
Messages
791
I added some code that will make the range selection dynamic. Your code is a little different than mine, so hopefully I put it in the right spots. They are left aligned so you can see where I added the code lines. I show two ways for the range one using RC numbers the other using letters. Used the record count of the recordset to determine the number of rows and the Range column count to determine how many cols. If the number of cols are fixed, then you wouldn't need to get the last col. There are two examples of using the range, uncomment the version you plan to use.

Code:
Public Function export_spreadsheet()

    On Error GoTo ErrorHandler
  
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
  
    Set db = CurrentDb
    Set rs = db.OpenRecordset("qry_chief_people_officer")
  
    DoCmd.Hourglass (True)
  
    Set xlApp = CreateObject("Excel.Application")

        With xlApp
            .Visible = False
            .Workbooks.Open _
            ("template.xlsx")
            .ActiveWorkbook.SaveAs ("template " & Format(Now(), "DD-MMM-YY") & ".xlsx")
            .ActiveWorkbook.Close
          
        End With

    Set xlBook = xlApp.Workbooks.Open("template " & Format(Now(), "DD-MMM-YY") & ".xlsx")
    Set xlSheet = xlApp.Worksheets(1)
  
        With xlSheet
            .Name = "CPO_Records" 'Rename the sheet

rs.MoveLast
rs.MoveFirst
lastRow = rs.RecordCount + 1
lastCol = .Range("A1").CurrentRegion.Columns.Count

              For cols = 0 To rs.Fields.Count - 1
             .Cells(2, cols + 1).Value = rs.Fields(cols).Name
             Next
             .Range("A3").CopyFromRecordset rs 'Copy data from recordsset to sheet
        End With
  
   'Adding the hyperlinks to the Excel spreadsheet
    Dim firstAddress As String, c As Range, r As Range
  
'        With xlSheet.Range("A1:AJ200") 'Improvement would be to make this dynamic, based on the exported spreadsheet

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''IF you know that it will always be starting in "A" and ending in "AJ", then you could do like this '''
'WITH xlsheet.Range("A1:"AJ" & lastrow)                                    'Uncomment if using this version
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''Otherwise use this for completly dynamic last row col'''''''''''''''''''''''''''''''''''''''''''''''''OR
'WITH xlsheet.Range(.cells(1,1), .cells(lastrow, lastcol)                        'Uncomment if using this version
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

            Set c = Cells.Find(What:="Click here for further information", LookIn:=xlValues, Lookat:=xlWhole, _
            MatchCase:=False)
          
            If Not c Is Nothing Then
                Set r = c
                firstAddress = c.Address
                Do
                    Set r = Union(r, c)
                    xlSheet.Range(c.Address).Activate
                    Set c = Cells.FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
            .Activate
            If Not r Is Nothing Then r.Select
        End With
  
          ActiveSheet.hyperlinks.Add Anchor:=r, Address:= _
            "MY-LINK" _
            , TextToDisplay:="Click here for further information"

         With xlApp
        .ActiveWorkbook.Save
        End With

    Set xlBook = Nothing
    Set xlSheet = Nothing
  
    MsgBox "File saved to your (U:) drive", vbInformation + vbOKOnly, "Export Success"
      
    DoCmd.Hourglass False
    xlApp.Visible = True

ErrorHandler:
    MsgBox "Export unsuccessful." & vbCrLf & vbCrLf & "The following error has occurred: " & Err.Description
    Exit Function

End Function
 

cgala

New member
Local time
Today, 11:31
Joined
Jan 29, 2021
Messages
10
Hi @sxschech,

Thanks for the reply! I need to set both the rows and columns dynamically so tried your second line (needed to add another bracket after the ...lastcol) , but got an error message from that line of code:

Compile error:

Invalid or unqualified reference

I did however manage to get the whole code, hyperlinks and all working, without using .Activate or .Select.

I got the range to be dynamic using UsedRange. As my spreadsheet is filled from A1 down, I didn't see any issues using UsedRange.

Code:
Public Function export_spreadsheet()
'This function exports a query from a table to an excel spreadsheet, saving it in the users U drive _
it also adds hyperlinks to certain cells in the exported spreasheet

'Note that the formatting of the spreadsheet is based on an Excel spreadsheet template.

    On Error GoTo ErrorHandler
 
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Set xlApp = CreateObject("Excel.Application")

    DoCmd.Hourglass (True) 'Show user work is being performed
 
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
 
    Set db = CurrentDb
    Set rs = db.OpenRecordset("qry_...")
 
'    Copy the file to the user's U drive
    Dim objFSO As Scripting.FileSystemObject
    Dim source_folder As String
    Dim source_file As String
    Dim destination_folder As String
    Dim destination_file As String

    source_folder = "FOLDER PATH"
    source_file = "MY FILE.xlsx"
    destination_folder = "U:\"
    destination_file = "YOUR NAME " & Format(Now(), "DD-MMM-YY") & ".xlsx"
       
    Set objFSO = New Scripting.FileSystemObject
 
    With objFSO
        If Not .FileExists(destination_folder & destination_file) Then
        .CopyFile source_folder & source_file, destination_folder & destination_file, False
        Else
            errMsg = "The file " & Chr(34) & destination_file & Chr(34) & "already exists in: " & Chr(34) & destination_folder & Chr(34) _
            & vbCrLf & "Please move or rename the exisitng file before tyring to export."
            GoTo ErrorHandler
        End If
    End With
 
    With xlApp
    .Visible = False 'Hide the Excel window from the user until the export is ready
    End With
 
    Set xlBook = xlApp.Workbooks.Open(destination_folder & destination_file)
    Set xlSheet = xlApp.Worksheets(1) 'Grab a reference to the first worksheet
 
'     This block of code copies the qry/table columns over to the spreadsheet.

    Dim cols As Integer

    With xlSheet
      .Name = "CPO_Records" 'Rename the sheet
   
        For cols = 0 To rs.Fields.Count - 1
       .Cells(2, cols + 1).Value = rs.Fields(cols).Name
       Next
   
       .Range("A3").CopyFromRecordset rs 'Copy data from recordsset to sheet
    End With
 
'This next block of code adds a hyperlink to cells in the exported spreadsheet that contain the searchTerm
    Dim searchTerm As String: searchTerm = "THE CELL VALUE TO SEARCH FOR"
    Dim hyper As String: hyper = "THE HYPERLINK.xlsx"
 
    Dim c As Range
    Dim firstAddress As String
 
    Dim r As Range
 

    With xlSheet.UsedRange
        Set c = .Find(searchTerm, lookin:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.Hyperlinks.Add Anchor:=c, Address:=hyper, TextToDisplay:=searchTerm
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
 
   xlBook.Saved = True

    Set xlSheet = Nothing
    Set xlBook = Nothing

    MsgBox _
    "Export Success." & _
    vbCrLf & _
    "File saved to your (U:) drive. " & _
    vbCrLf & _
    "Please check the hyperlinks in the " & Chr(34) & "Description" & Chr(34) & " column.", _
    vbInformation + vbOKOnly
       
    DoCmd.Hourglass False
    xlApp.Visible = True

Exit Function

ErrorHandler:
    If errMsg = vbNullString Then
    Set xlSheet = Nothing
    Set xlBook = Nothing
    MsgBox "Export unsuccessful." & vbCrLf & vbCrLf & "The following error has occurred: " & Err.Description
    Else
    Set xlSheet = Nothing
    Set xlBook = Nothing
    MsgBox "Export unsuccessful." & vbCrLf & errMsg
    End If
    Err.Clear
 
End Function
 
Last edited:

sxschech

Registered User.
Local time
Today, 04:31
Joined
Mar 2, 2010
Messages
791
Good to know that the used range met your needs, that seems simpler than having to calculate the cells.
Sorry my code didn't work in your case. Maybe I didn't copy all the parts that were needed.
 

cgala

New member
Local time
Today, 11:31
Joined
Jan 29, 2021
Messages
10
Good to know that the used range met your needs, that seems simpler than having to calculate the cells.
Sorry my code didn't work in your case. Maybe I didn't copy all the parts that were needed.
Yep, I think if I were to do it again, I would try something similar to your method to test it out, and to reduce the potential for errors. If I end up tweaking it, I'll post! Thanks all the same :)
 

Users who are viewing this thread

Top Bottom