Find Hperlinks in column and copy entire row to new sheet

[Bonacci8]

I have a group of worksheets that I want to cycle through and look in column A for a hyperlink. If the cell has a hyper link in it I want to copy the entire row to the work sheet pTable. I have pieced the code below together as a first step to copy the just the link but it does not work with the .columns("A:A") porperty. It will work if I change it to .range but then I get every hyperlink on the sheet. Any Ideas? Thanks!


Sub Createprogramlist()
'finds hyperlinks and copies to pTable
Dim rCell As Range
Dim wSheet As Worksheet
Dim hLink As Long, cLink As Long
ThisWorkbook.Activate
For Each wSheet In Worksheets
If wSheet.Name <> "WebLaunch" And wSheet.Name <> "Tables" And wSheet.Name <> "pTable" Then
For hLink = 1 To wSheet.Columns("A:A").Hyperlinks.Count
'need to get hLink in column A
wSheet.Hyperlinks(hLink).Columns("A:A").Activate
wSheet.Hyperlinks(hLink).Columns("A:A").Copy _
Sheets("pTable").Cells(Rows.Count, 1).End(xlUp)(2, 1)
Next hLink
End If
Next wSheet
End Sub

 

[nirvana_]

Try this.

If you are re-running the program you will have to delete the "Copied Hyperlinks" sheet.

Option Explicit
Sub CopyHyperlinks()
    Dim WS As Worksheet
    Dim i As Integer
    Dim j As Integer
    j = 1
    Dim MyHyperlink As Hyperlink
    Set WS = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    WS.Name = "Copied Hyperlinks"
    For i = 1 To (Worksheets.Count - 1)
        For Each MyHyperlink In Worksheets(i).Hyperlinks
            If Worksheets(i).Name <> "WebLaunch" And Worksheets(i).Name <> "Tables" And Worksheets(i).Name <> "pTable" Then
                If MyHyperlink.Range.Column = 1 Then
                    Worksheets(i).Rows(MyHyperlink.Range.Row).Copy
                    WS.Range("A" & j).PasteSpecial xlPasteAll
                    j = j + 1
                End If
            End If
        Next
    Next
End Sub

 

[Bonacci8]

Brilliant! Works great! Thanks!

Pete