How to copy hyperlinked words

[ritesh_akh]

Hi,

I need help to get a macro code for the following purpose:-

Part - 1

In cell A1-A100 are some date. There are some cells which have hyperlinked words. What is required that it searches the column A and copy only those texts to column B which are hyperlinked. (It should not copy the URL)

For Eg:
|A | B |
1 Click Here Click Here
2 Yes
3 Go To Page Go To Page
4

and so on...

Part - 2:
After copying the hyperlinked words to column B, i want to delete some cell values which have a specific word in column B.

Part - 3:
Copy all the values of column B to new worksheet with deleting all the empty rows in between.

Please help me on this as i not very much aware of macro coding.

Thanks.
Ritesh.

 

[Ralajer]

Ritesh welcome to the board. The following code should do what you want but you will have to change some of the values specific to you application.

Sub HyperlinkCopy()
    Dim newWBPath As String, deleteIF As String
    Dim hlRange As Range, outputRng As Range
    
    Set hlRange = Range("A1:A100")
    Set outputRng = Range("B1:B100")
    
    deleteIF = "Test"
    newWBPath = ActiveWorkbook.Path & "\"
    newWBPath = newWBPath & "Name.xlsx"

    linkTextToDisplay hlRange
    parseTextToDisplay outputRng, deleteIF
    copyToNewWB newWBPath, outputRng
    
End Sub

Private Function linkTextToDisplay(hlRng As Range)
    Dim hl As Hyperlink

    '// Loop through range and extract
    For Each hl In hlRng.Hyperlinks
        Cells(hl.Parent.Row, hl.Parent.Column + 1).Value = hl.TextToDisplay
    Next hl
      
End Function

Private Function parseTextToDisplay(outRng As Range, deleteIF As String)
    Dim cell As Range
    
    For Each cell In outRng
        If InStr(1, cell.Value, deleteIF, vbTextCompare) > 0 Then cell.Value = Empty
    Next cell
End Function

Private Function copyToNewWB(newWBPath As String, outputRng As Range)
    Dim wbNew As Workbook
    Dim cell As Range
    Dim i As Long
    '// Create new Workbook
    Set wbNew = Workbooks.Add
    Application.DisplayAlerts = False
    wbNew.SaveAs Filename:=newWBPath
    
    i = 1
    With wbNew.Worksheets("Sheet1")
    
    For Each cell In outputRng
        If Len(cell.Value) > 0 Then
            .Cells(i, 1).Value = cell.Value
            i = i + 1
        End If
    Next cell
    
    End With
End Function

 

[ritesh_akh]

Thanks Ralajer! Thank you so much. You made my day. Thanks again