Copy webpage hyperlinks

[platesigns]

Copy webpage hyperlinks

Hi

I want to copy the hyperlinks on these pages and insert in excel - is there perhaps a macro that can do this

https://registers.cidb.org.za/Public...=1100001001000
https://registers.cidb.org.za/Public...=1100001001000
https://registers.cidb.org.za/Public...=1100001001000
https://registers.cidb.org.za/Public...=1100001001000

thanks

imtiaz

[Marc L]

Hi !

Maybe its possible if we should know what is exactly needed ‼

So attach a sample result worksheet from a webpage …

[platesigns]

hi

sample file attached with page 1 and page 2 results - I selected the hyperlinks and copied but if that cannot be done then maybe we can copy the entire page and paste in excel and thereafter delete the unnecessary parts

thanks

[Marc L]

Do you need to keep links in column CRS or just text only ?

[platesigns]

I need to keep the links in column CRS only - other columns and other info not required

[Marc L]

Try in a new workbook, must paste code to a worksheet module :

Sub DemoXML()
    Const HST$ = "registers.cidb.org.za", SRC$ = "https://" & HST, _
          URL$ = "/PublicContractors/ContractorSearch?PageSize=40&PageNo=1&Region=4be86b26-80c6-e111-a22d-00155d022301&Columns=1100001001000"
    Dim Hlnk As Hyperlink
    Application.StatusBar = "        Web download …"

    With CreateObject("Microsoft.XMLHTTP")
        .Open "GET", SRC & URL, False
        .setRequestHeader "DNT", "1"
        .setRequestHeader "Host", HST
        On Error Resume Next
        .send
        On Error GoTo 0
        If .Status = 200 Then T$ = .ResponseText
    End With

    If T = "" Then
        Beep
    Else
        With CreateObject("HTMLfile")
            .Write T

            If .parentWindow.clipboardData.setData("Text", _
               .getElementsByTagName("TABLE")(1).outerHTML) Then
                Application.ScreenUpdating = False:  Me.Paste [B1]
                .parentWindow.clipboardData.clearData "Text"
                [A2].Select:  ActiveWindow.FreezePanes = True

                With [B1].CurrentRegion
                    For Each Hlnk In .Columns(1).Hyperlinks
                        With Hlnk
                            .Address = SRC & .Address:  .ScreenTip = "View Contractor webpage"
                        End With
                    Next

                    .WrapText = False:  .Columns("A:B").AutoFit
                End With
            End If

            .Close
        End With
    End If

    Application.StatusBar = False:  End
End Sub

As the website is pretty slow, procedure needs around 30s to load 40 links …

You just have to moderate the data according to your needs …

Enjoy it and don't forget to click on bottom left button Add Reputation of this post !

[platesigns]

Hi

I am getting an error at line : Me.Paste [B1] - invalid key Me

also how do I do it for multiple pages i.e. page 1 to say page 5

[Marc L]

'Cause you didn't apply :

Try in a new workbook, must paste code to a worksheet module :

You can also in code place cursor on Me statement and hit F1 key and read …

And as you should read in the code, 40 lines are directly requested !
So if you need more, increase PageSize or PageNo …

[platesigns]

Hi

it works perfectly except that it is limited to 150 lines per page by the webpage itself
so there has to be a FOR loop for page numbers

[Leith Ross]

Hello platesigns,

Here is another version. It uses 2 worksheets. "Sheet2" holds all the URLs you want to return CRS lnks from. "Sheet1" displays the CRS numbers and each one is linked to its contractor page.

The worksheets and the ranges used can be easily changed if needed. The end of range for the URLs is automatically found . You only need to provide the starting cell address. Likewise, the CRS numbers are added after the starting cell for the destination address.

A blank row is inserted after the CRS numbers are copied to the worksheet. Not sure if this a feature you need. if not, it is easy to remove.

There is a button on "Sheet2" to run the macro. Have a look at the attached workbook.


Here is the code for the macro. It is commented to help you understand the code better.

Option Explicit

Sub GetCRS()

    Dim BaseURL As String
    Dim CRS     As Variant
    Dim Doc     As Object
    Dim DstRng  As Range
    Dim DstWks  As Worksheet
    Dim EndRow  As Long
    Dim Hlink   As String
    Dim n       As Long
    Dim oTable  As Object
    Dim PageSrc As String
    Dim SrcRng  As Range
    Dim SrcWks  As Worksheet
    Dim URL     As Variant
    
    
        BaseURL = "https://registers.cidb.org.za/"
        
        
      ' Initalize the source and destination range variables.
        Set SrcWks = Worksheets("Sheet2")
        Set SrcRng = SrcWks.Range("A1")
        
        Set DstWks = Worksheets("Sheet1")
        Set DstRng = DstWks.Range("A1")
        
        
          ' Determine the extent of the source range.
            EndRow = SrcWks.Cells(Rows.Count, SrcRng.Column).End(xlUp).Row
            If EndRow < SrcRng.Row Then Exit Sub Else Set SrcRng = SrcRng.Resize(EndRow - SrcRng.Row + 1, 1)
            
          ' Determine the destination cell.
            EndRow = DstWks.Cells(Rows.Count, DstRng.Column).End(xlUp).Row
            Set DstRng = IIf(EndRow <= DstRng.Row, DstRng, DstWks.Cells(EndRow + 1, DstRng.Column))
           
              ' Loop through each hyperlink in the source range.
                For Each URL In SrcRng.Cells
                    
                  ' Allow the user to interrupt the loop.
                    DoEvents
                    
                  ' Access the web page.
                    With CreateObject("MSXML2.XMLHTTP")
                        .Open "GET", URL, False
                        .send
                        PageSrc = .responseText
                    End With
        
                  ' Create an HTML DOM document from the page source.
                    Set Doc = CreateObject("HTMLfile")
                    Doc.Write PageSrc
        
                    Set oTable = Doc.getelementById("tblContractorsDetails")
        
                  ' Get the CRS numbers and links from the web page.
                    For n = 0 To oTable.Rows.Length - 1
                        With oTable.Rows(n).Cells(0).ChildNodes(0)
                            Hlink = Replace(.href, "about:/", BaseURL)
                            CRS = .innerHTML
                        End With
                        
                      ' Create a hyperlink on the destination worksheet fro each CRS.
                        DstRng.Hyperlinks.Add Anchor:=DstRng, Address:=Hlink, TextToDisplay:=CRS
                        Set DstRng = DstRng.Offset(1, 0)
                    Next n
                    
                  ' Skip a row between web pages.
                    Set DstRng = DstRng.Offset(1, 0)
                    
                Next URL
        
End Sub

[platesigns]

hi

what I don't follow is how are setting the code to 4 pages and 10 results per page ?

[Marc L]

Hi,

yes you can increase parameter PageNo !

[platesigns]

u can do each page number on its own but can u do them in one go i.e. page 1,2,3 and 4 one after the other automatically