VBA to scrape website page into a single cell in excel

zack01

New Member
Joined
Apr 24, 2015
Messages
6
Hello,
I am still picking on my VBA but not there yet. I am trying to work on a vba code that will open a webpage from a cell in excel scrape into a formatted text and place into a single cell in the same worksheet. The pages i am trying to grab are not the same in structure.
After searching on the web i was able to review codes from other people and put pieces together to work. the problem is that what i have works some what, but the pages that is pulled in excel comes in with the formatting and merge cells are not able to be handled. Also the process is slow when run which keeps my system tied up, making it unable to do other site.

Please see attached code and any help that io can get will be deeply appreciated. thank

code:
1. links are put into E of excel sheet
2. webpage destination is in column P
3. I have a search word in G1 that goes through the data in P and if it exist returns a Yes in column K.

Thank you

Code:
Public strsearch As String

Sub SearchSite()
   Range("E2").Select
    Range(Selection, Selection.End(xlDown)).Select
    For j = Selection.Row To Selection.Row + Selection.Rows.Count - 1

' Get the URL
       theurl = Range("E" & j)
       If theurl = "" Then GoTo NextRow

    ' Fill the query table
            With ActiveSheet.QueryTables.Add(Connection:="URL;" & theurl, Destination:=Range("P" & j))
            .Name = "NewsQuery"
            .AdjustColumnWidth = False
            .RefreshStyle = xlOverwriteCells
            .TablesOnlyFromHTML = False
            .Refresh BackgroundQuery:=False
            .SaveData = False

End With
combineCellsIntoOne Range("P" & j)

' Search the Query Table for the Search Term
strsearch = Range("G1")
bottomrow = Range("P" & Rows.Count).End(xlUp).Row

For i = j To bottomrow
If InStr(Range("P" & i), stresearch) <> 0 Then
   Range("K" & j) = "YES"
Exit For
End If
Range("K" & j) = "YES"
Next i

NextRow:
Next j

End Sub

Sub combineCellsIntoOne(dest As Range)
Dim lastRow As Long
lastRow = Cells(Rows.Count, dest.Column).End(xlUp).Row

Dim i As Long

For i = dest.Row + 1 To lastRow
dest.Value = dest.Value & " " & Cells(i, dest.Column).Value
Application.DisplayAlerts = flash
Cells(i, dest.Column).Delete 'Clear ‘Contents
Application.DisplayAlerts = True

Next i

End Sub
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

Forum statistics

Threads
1,223,099
Messages
6,170,108
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top