Try this:

Sub Routine1
Read_URL_Test
Chap11aProc02_GetHyperlinkInfo
Read_ActiveLinks_Test
End Sub

Sub Read_URL_Test()

Dim URLname As String
Dim wc As Worksheet

'Row = 10

' While Worksheets("User").Cells(Row, 7) < ""

Set wc = Worksheets("Data Dictionary Index")
' Worksheets(wc).Select
wc.Select
Cells.Select
Selection.clear
' Selection.QueryTable.Delete

URLname = Worksheets("User").Cells(6, 7).Value

Sheets("Data Dictionary Index").Activate

' this copies it to successive spreadsheet
' Worksheets.Add.Move after:=Worksheets(Worksheets.Count)

With ActiveSheet.QueryTables.Add(Connection:="URL;" & URLname, _
Destination:=Range("a1"))

.BackgroundQuery = True
.TablesOnlyFromHTML = False
.Refresh BackgroundQuery:=False
.SaveData = True
End With

row = row + 1

' Wend

End Sub


'Display Hyperlink Information
'This routine displays information about each
'hyperlink
'================================================

Sub Chap11aProc02_GetHyperlinkInfo()
Dim LinkVar As Hyperlink
Dim sLinkInfo As String
Dim sLinkName As String
Dim sSubAddress As String
Dim sTextToDisplay As String
Dim row As Double
Dim wc As Worksheet


Set wc = Worksheets("User")
wc.Select
Range("B11:L11").Select
wc.Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents


row = 11
' With Sheets(2)
With Sheets("Data Dictionary Index")
.Activate
For Each LinkVar In .Hyperlinks
With LinkVar
' sLinkInfo = "Name: " & .Name & Chr(13)
sLinkName = "Name: " & .Name
' sLinkInfo = sLinkInfo & "Address: " & .Address & Chr(13)
sLinkInfo = .Address
' sLinkInfo = sLinkInfo & "Subaddress: " & .SubAddress &
Chr(13)
sSubAddress = "Sub Address: " & .SubAddress
sTextToDisplay = .TextToDisplay

If .Type = msoHyperlinkRange Then
slinkRange = "Range: " & .Range
' sLinkInfo = sLinkInfo & "Range: " & .Range.Address &
Chr(13)
Else
slinkRange = "Range: " & .Range
' sLinkInfo = sLinkInfo & "Shape: " & .Shape.Name & Chr(13)
End If
End With
' MsgBox sLinkInfo
Worksheets("User").Cells(row, 2).Value = sTextToDisplay
Worksheets("User").Cells(row, 7).Value = sLinkInfo
row = row + 1
Next LinkVar
End With
End Sub

Sub Read_ActiveLinks_Test()

Dim URLname As String
Dim wc As Worksheet
Dim Count As Integer
Dim namee As String
Dim temp As String
Dim charr As Integer

row = 11
Count = 1

While Worksheets("User").Cells(row, 7) < ""

URLname = Worksheets("User").Cells(row, 7).Value

Worksheets.Add.Move after:=Worksheets(Worksheets.Count)

With ActiveSheet.QueryTables.Add(Connection:="URL;" & URLname, _
Destination:=Range("a1"))

.BackgroundQuery = True
.TablesOnlyFromHTML = False
.Refresh BackgroundQuery:=False
.SaveData = True
End With


namee = " "
namee = ThisWorkbook.Worksheets("User").Cells(row, 2).Value

charr = InStr(1, namee, "/")
If charr 0 Then
temp = Replace(namee, "/", " ")
namee = temp
Else
charr = InStr(1, namee, "-")
If charr 0 Then
temp = Replace(namee, "-", " ")
namee = temp
Else
charr = InStr(1, namee, "*")
If charr 0 Then
temp = Replace(namee, "*", " ")
namee = temp
End If
End If
End If



On Error GoTo errorhandler
ActiveSheet.Name =
Trim(ThisWorkbook.Worksheets("User").Cells(row,2). Value)

row = row + 1

Wend

GoTo fin:


errorhandler:


MsgBox ("Error Number = " & Err.Number & " " & Chr(13) & _
"Err Message = " & Err.Description & " " & Chr(13) & _
namee)

Resume Next

fin:

Worksheets(1).Activate

End Sub










"Pedro Costa" wrote:

Is there a way to create a macro in order to copy the entire page in an
internet site to excel?

Ill try to explain it better :

I have a list of hyperlinks in a sheet (sheet1), the macro should open these
hyperlinks and copy all the content of the page and paste it to a certain
sheet (sheet2) in my workbook.

Is this possible?