Get Table from website into Excel VBA

Hi,

I work for a Stationery company and we constantly need to find cartridges for Printers with a Printer Supplied

I'm trying to get data from a website into Excel.
The Website is http://www.dynamicsupplies.com.au
the search URL is http://www.dynamicsupplies.com.au/search.php?Vendor2=Search+All+Manufacturers&q=%CODE%&Submit=Search
replacing %CODE% with a search string from Excel

I know a fair bit about Excel and VBA but i'm hopeless when it comes to HTML and the Code tags.

I've attached a before and after of what i would like
I have Chrome and (obviously) internet Explorer installed.

can anyone point me in the right direction?
EE---Dynamics-Search.xls
LVL 10
bromy2004Asked:
Who is Participating?

[Webinar] Streamline your web hosting managementRegister Today

x
 
Dave BrettConnect With a Mentor Vice President - Business EvaluationCommented:
This gets you 98% of the way there. :)

There is a little bit of data cleaning needed on column H

Cheers

DAve

Sub GetWeb()
    Dim objIe
    Dim objRegEx
    Dim RegMC
    Dim RegM
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim c As Range
    Dim strTemp As String

    With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    End With
    
    Set ws1 = ActiveWorkbook.Sheets(1)
    Set ws2 = ActiveWorkbook.Sheets(2)
    Set rng1 = ws1.Range(ws1.[b1], ws1.Cells(Rows.Count, "B").End(xlUp))
    Set objIe = CreateObject("internetexplorer.application")
    Set objRegEx = CreateObject("vbscript.regexp")

    objRegEx.Global = True

   ws2.UsedRange.ClearContents
    For Each c In rng1
        objIe.Navigate c.Value
        Do While objIe.ReadyState <> 4
            DoEvents
        Loop
        objRegEx.Pattern = "[\n\r\t]"
        '  Debug.Print objIe.Document.body.innerhtml
        strTemp = objIe.Document.body.innerhtml
        strTemp = objRegEx.Replace(strTemp, vbNullString)
        objRegEx.Pattern = "(<TD>.+?<\/TD>)+"
        Set RegMC = objRegEx.Execute(strTemp)
        For Each RegM In RegMC
            ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Replace(RegM, "</TD><TD>", "|")
        Next
    Next c
    ws2.Columns("A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, OtherChar:="|"
    ws2.Columns("A").Replace "<TD>", vbNullString
    ws2.Columns("I:M").ClearContents
    objIe.Quit
     With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    End With
End Sub

Open in new window

EE---Dynamics-Search-1.xls
0
 
proadminCommented:
Believe it or not Excel is really good taking tables from HTML pages - try copy and pasting into your XLS file - if that isn't good then try copy and pasting into a Wordpad file and then into Excel from there.

Hope that helps!
0
 
bromy2004Author Commented:
I would normally do that,
thats how i got the "Results"
however the list is generally 10-50 Printers, and searching for each link and returning the table is time consuming
so i was hoping a macro would do it.
0
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

 
Dave BrettVice President - Business EvaluationCommented:
I'm working on it  ... it's a litte tricky as it requires regex parsing on an automated explorer html string

Cheers

Dave


0
 
bromy2004Author Commented:
thank you dave,
although that last bit flew straight over my head. :s
0
 
bromy2004Author Commented:
I've run in on my Workbook as well as your supplied workbook, but the TextToColumns isn't working

How does the RegExp work?
I noticed you've set the "Pattern" twice.
ScreenShot002.jpg
0
 
Dave BrettVice President - Business EvaluationCommented:
Thats strange, it should just be splitting the column on the "|" data as my sample file did. I presume it works manually?

I retested my file and it worked fine

I use the first pattern to strip out all line breaks so that I have a single string to parse, the second pattern looks for strings contained in between the </TD> and </TD>

Cheers

Dave
0
 
bromy2004Author Commented:
Figured it out,

the TextToColumns was missing  Other:=True
Have added and works fine, except for the last line, which remains as a long string
0
 
Dave BrettVice President - Business EvaluationCommented:
Yep, that was the 2% part I figured would be your direction bit.

 I'm out of time to tweak that part further :)

Dave
0
 
tilsantCommented:
After looking at u guys, im seriously thinking of learning VB!!

But for now, this is from my side (i guess this is going to be the crudest code ever!!)
:P


Tils.
0
 
tilsantConnect With a Mentor Commented:
the code follows ;)
Sub Macro4()
    Sheets("Search for").Select
    Range("A1:A2").Select
    rng = Selection
    Sheets.Add
    Dim x As Variant
    For Each x In rng
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.dynamicsupplies.com.au/search.php?Vendor2=Search+All+Manufacturers&q=" & x & "&Submit=Search" _
        , Destination:=ActiveCell)
        .Name = _
        "search.php?Vendor2=Search+All+Manufacturers&q=" & x & "&Submit=Search"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Selection.End(xlToLeft).Select
    Selection.EntireRow.Delete
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Insert Shift:=xlToRight
    ActiveCell.Select
    Selection.End(xlToLeft).Select
    ActiveCell.Value = x
    ActiveCell.Copy
    Selection.End(xlToRight).Select
    Selection.End(xlDown).Select
    Selection.End(xlToLeft).Select
    Selection.End(xlToLeft).Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    Selection.EntireRow.Delete
    Next
    Range("A1").Select
    Application.CutCopyMode = False
    Selection.EntireRow.Insert
    ActiveCell.FormulaR1C1 = "Original Code"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Dynamic Code"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Vendor Code"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Manufacturer"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Description"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Colour"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Yield"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Category"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Printer Models"
    ActiveCell.Offset(0, 1).Range("A1:C1").Select
    Selection.EntireColumn.Delete
    ActiveCell.Cells.Select
    ActiveCell.Cells.EntireColumn.AutoFit
    Range("A1").Select
End Sub

Open in new window

0
 
bromy2004Author Commented:
Tils,
That is really good, and clear enough to understand.

I'll use that one with another macro i'm using.
0
 
bromy2004Author Commented:
Well done and Thank you to Dave and Tils
0
 
tilsantCommented:
k....... kool :)
0
 
tilsantCommented:
Thanks for the Points, Broomy =)


Tils.
0
All Courses

From novice to tech pro — start learning today.