Imported Hyperlinks lose link

Sprock

New Member
Joined
Jun 16, 2011
Messages
7
I am VBA noob extraordinaire.

I am merging data from multiple WBs. The Source WBs and destination WB are .xls.

In all the source WBs, the D column contains hyperlinks that work in the source but after copy in the destination the Address is missing from the Hyperlink properties.


Here is the code I am using it does everything I need except maintain the hyperlinks.

Code:
Function RDB_Last(choice As Integer, rng As Range)
' By Ron de Bruin, 5 May 2008
' A choice of 1 = last row.
' A choice of 2 = last column.
' A choice of 3 = last cell.
   Dim lrw As Long
   Dim lcol As Integer
   Select Case choice
   Case 1:
      On Error Resume Next
      RDB_Last = rng.Find(What:="*", _
                          after:=rng.Cells(1), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
      On Error GoTo 0
   Case 2:
      On Error Resume Next
      RDB_Last = rng.Find(What:="*", _
                          after:=rng.Cells(1), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Column
      On Error GoTo 0
   Case 3:
      On Error Resume Next
      lrw = rng.Find(What:="*", _
                    after:=rng.Cells(1), _
                    Lookat:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
      On Error GoTo 0
      On Error Resume Next
      lcol = rng.Find(What:="*", _
                     after:=rng.Cells(1), _
                     Lookat:=xlPart, _
                     LookIn:=xlFormulas, _
                     SearchOrder:=xlByColumns, _
                     SearchDirection:=xlPrevious, _
                     MatchCase:=False).Column
      On Error GoTo 0
      On Error Resume Next
      RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
      If Err.Number > 0 Then
         RDB_Last = rng.Cells(1).Address(False, False)
         Err.Clear
      End If
      On Error GoTo 0
   End Select
End Function
 
 
Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim FirstCell As String
 
    ' Change this to the path\folder location of your files.
    MyPath = "X:\xxx\xxx\xxx"
    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
    ' Fill the myFiles array with the list of Excel files
    ' in the search folder.
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop
    ' Set various application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ' Add a new workbook with one sheet.
    Set BaseWks = Workbooks("Master_xDrv.xls").Worksheets(1)
    rnum = BaseWks.Cells(Rows.Count, 1) _
  .End(xlUp).Offset(1, 0).Row
    ' Loop through all files in the myFiles array.
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0
            If Not mybook Is Nothing Then
                On Error Resume Next
                ' Change this range to fit your own needs.
                 With mybook.Worksheets("Data")
                    FirstCell = "A2"
                    Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
                    ' Test if the row of the last cell is equal to or greater than the row of the first cell.
                    If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
                    Set sourceRange = Nothing
                    End If
                End With
                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If source range uses all columns then
                    ' skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0
                If Not sourceRange Is Nothing Then
                    SourceRcount = sourceRange.Rows.Count
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
                        ' Copy the file name in column A.
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(FNum)
                        End With
                        ' Set the destination range.
                        Set destrange = BaseWks.Range("B" & rnum)
                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value
                        rnum = rnum + SourceRcount
                        sourceRange.Value = ""
                    End If
                End If
                mybook.Close savechanges:=True
            End If
        Next FNum
        BaseWks.Columns.AutoFit
    End If
ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

Ralajer

Active Member
Joined
Jul 24, 2008
Messages
416
I think there is a simple work around but it depends on a few things. Is Column D just hyperlinks and is it hyperlinks in that column of each workbook? Also is the hyperlink in column D hyperlink set with the =HYPERLINK() function or is just text with that has the hyperlink attached? The goal is not to have any reference required from the source sheet which if using HYPERLINK() function there might be.

If all the above is not an issue add this line.

sourceRange.Columns(4).Copy destrange.Columns(4)​
after this line (which is 18~ lines from the bottom)
destrange.Value = sourceRange.Value​
 

Sprock

New Member
Joined
Jun 16, 2011
Messages
7
The source workbooks are all the same, and are VBA forms with a Data ws that stores the inputs in columns 1, 2, 3. This data is combined to create a unique file name:

Code:
Private Sub BuildFileName_Click()
    Me.[txtFile] = [TerminalName] & "_" & [txtInitials] & [txtNumber] & "_" 
& [txtDate] & ".pdf"

Which in turn is used to create the Hyperlink in column 4 using =HYPERLINK():

Code:
'copy the data to the database
ws.Cells(iRow, 1).Value = Me.TerminalName.Value
ws.Cells(iRow, 2).Value = Me.txtInitials.Value
ws.Cells(iRow, 3).Value = Me.txtNumber.Value
ws.Cells(iRow, 4).Formula = 
"=HYPERLINK(""" & "X:\xxx\xxxx_Data\Event_Log_PDFs\" & Me.txtFile.Value & """)"
ws.Cells(iRow, 5).Value = Me.txtComment.Value
ws.Cells(iRow, 6).Value = Now

The result in Column 4 that is saved is like this

Code:
=HYPERLINK("X:\xxx\xxx_Data\Event_Log_PDFs\Test_Terminal_xxxx000000_2011Jun15.pdf")

Is there a macro the user can run after import to change the text in colunm 4 (excluding the header) to hyperlinks?
The text that is pulled in is the link address. for example: X:\xxx\xxx_Data\Event_Log_PDFs\Test_Terminal_xxxx000000_2011Jun15.pdf

Thank you very much for your reply.
 

Sprock

New Member
Joined
Jun 16, 2011
Messages
7
Rob,

Thanks for your reply.

I tested the additional code in a early version of my wb and didn't work. Hence the above reply.

BUT it works in the final version.

I need more Coffee before I start coding it seems.

Once again thank you.

Ken
 

Watch MrExcel Video

Forum statistics

Threads
1,132,685
Messages
5,654,746
Members
418,149
Latest member
amamiche67

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top