Loop through a list of URLs in Sheet 1 and strip data from each URL onto a separate worksheet

[stirlingmw1]

I have the following code that stripe the entire webpage from a single url and pastes the data onto "Result" worksheet.

Private Sub UseQueryTable()
    Dim url As String
    Dim table As QueryTable
   
    url = "Page URL"
    Set table = shResult.QueryTables.Add("URL;" & url, shResult.Range("A1"))
        With table
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone ' no web formatting.
        .Refresh
    End With
End Sub

I would like to now modify this code so that it loops through a list of URLs I have on Sheet1 Column A (A1:A558") and paste the return to its on worksheet. Sheet1 Column A has a list of URLs and Column B has a list of the desired Worksheet names.
Can anyone help.

TIA

Steve

 

[Domenic]

The following code (note that there's no error handling) . . .

Private Sub CreateQueryTables()

    Dim urlRange As Range
    With Worksheets("Sheet1")
        Set urlRange = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With
    
    Dim currentCell As Range
    For Each currentCell In urlRange
    
        If Len(currentCell) > 0 And Len(currentCell.Offset(, 1)) > 0 Then
        
            Dim urlAddress As String
            urlAddress = currentCell.Value
            
            Dim newWorksheetName As String
            newWorksheetName = currentCell.Offset(, 1).Value
            
            Dim newWorksheet As Worksheet
            Set newWorksheet = Worksheets.Add(after:=Sheets(Sheets.Count))
            
            newWorksheet.Name = newWorksheetName
            
            Dim currentQueryTable As QueryTable
            Set currentQueryTable = newWorksheet.QueryTables.Add("URL;" & urlAddress, newWorksheet.Range("A1"))
            
            With currentQueryTable
                .WebSelectionType = xlEntirePage
                .WebFormatting = xlWebFormattingNone ' no web formatting.
                .Refresh
            End With
            
        End If
        
    Next currentCell
    
End Sub

Hope this helps!

 

[stirlingmw1]

The following code (note that there's no error handling) . . .

Private Sub CreateQueryTables()

    Dim urlRange As Range
    With Worksheets("Sheet1")
        Set urlRange = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With
   
    Dim currentCell As Range
    For Each currentCell In urlRange
   
        If Len(currentCell) > 0 And Len(currentCell.Offset(, 1)) > 0 Then
       
            Dim urlAddress As String
            urlAddress = currentCell.Value
           
            Dim newWorksheetName As String
            newWorksheetName = currentCell.Offset(, 1).Value
           
            Dim newWorksheet As Worksheet
            Set newWorksheet = Worksheets.Add(after:=Sheets(Sheets.Count))
           
            newWorksheet.Name = newWorksheetName
           
            Dim currentQueryTable As QueryTable
            Set currentQueryTable = newWorksheet.QueryTables.Add("URL;" & urlAddress, newWorksheet.Range("A1"))
           
            With currentQueryTable
                .WebSelectionType = xlEntirePage
                .WebFormatting = xlWebFormattingNone ' no web formatting.
                .Refresh
            End With
           
        End If
       
    Next currentCell
   
End Sub

Hope this helps!

Fantastic Thank you so much, works perfect. I was having trouble with an error but realised that Worksheet tab names are limited to 31 characters, after reducing the data in Column B and adding error handling it worked as I needed.

Thank you again.

Steve

 

[Domenic]

That's great, I'm glad I was able to help.

And I'm glad you were able to deal with that error.

Cheers!