' For more information or contact info, please visit
'
'      http://BlindCoinCollector.com/harvester
'
' To customize this macro, look for comment lines which contain the word "customize"
'
' Harvester, Version 2.0
    
    
    Option Explicit
Sub harvester()
    Dim i As Integer
Dim xml    As Object
Dim objTable As Object
Dim result As String
Dim lRow As Long
Dim lngTable As Long
Dim lngRow As Long
Dim lngCol As Long
Dim ActRw As Long
Dim s As String
Dim t1 As Object
Dim t2 As Object
Dim td As Object
Dim th As Object
Dim tr As Object
Dim e As Object
Dim h As Object


' define variables
Dim URL As String
Dim urllocation As Integer
Dim temprange As Range
Dim qt As QueryTable
Dim ws As Worksheet
Dim country As Integer
Dim countryvalue As String
Dim coin As Integer
Dim coinvalue As String
Dim km As Integer
Dim kmvalue As String
Dim cointype As Integer
Dim cointypevalue As String
Dim curren As Integer
Dim currenvalue As String
Dim year As Integer
Dim yearvalue As String
Dim metal As Integer
Dim metalvalue As String
Dim weight As Integer
Dim weightvalue As String
Dim diameter As Integer
Dim diametervalue As String
Dim thickness As Integer
Dim thicknessvalue As String
Dim edge As Integer
Dim edgevalue As String
Dim shape As Integer
Dim shapevalue As String
Dim obverse As Integer
Dim obversevalue As String
Dim obverselegend As Integer
Dim obverselegendvalue As String
Dim obversedesigner As Integer
Dim obversedesignervalue As String
Dim reverse As Integer
Dim reversevalue As String
Dim reverselegend As Integer
Dim reverselegendvalue As String
Dim reversedesigner As Integer
Dim reversedesignervalue As String
Dim subject As Integer
Dim subjectvalue As String
Dim Val As Integer


' define where you store values inside a record
' customize
'Example: if URL is in column H, set urllocation to 8

urllocation = 8
' Example: if country is in column A, set country to 1

country = 1
coin = 3
km = 7
year = 9
metal = 10
weight = 11
diameter = 12
thickness = 13
shape = 17
edge = 16
obverse = 18
obverselegend = 19
obversedesigner = 20
reverse = 21
reverselegend = 22
reversedesigner = 23
curren = 24
subject = 26

' end of customize

Val = 0

URL = ActiveSheet.Cells(ActiveCell.Row, urllocation)

Dim http As Object, html As New HTMLDocument, topics As Object, titleElem As Object, detailsElem As Object, topic As HTMLHtmlElement
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", URL, False
http.send
    Do While http.readyState <> 4: DoEvents: Loop

html.body.innerHTML = http.responseText

Dim pg As Object

Set pg = html.body.getElementsByTagName("table")


' get features

Set t1 = pg.Item(0)
Set t2 = pg.Item(1)
Set th = t1.getElementsByTagName("th")
Set td = t1.getElementsByTagName("td")

For i = 0 To t1.getElementsByTagName("th").Length - 1
If th.Item(i).innerText = "Country" Then countryvalue = td.Item(i).innerText
If InStr(th.Item(i).innerText, "Year") > 0 Then yearvalue = td.Item(i).innerText
If th.Item(i).innerText = "Composition" Then metalvalue = td.Item(i).innerText
If th.Item(i).innerText = "Weight" Then
 weightvalue = td.Item(i).innerText
weightvalue = Mid(weightvalue, 1, Len(weightvalue) - 2)
End If
If th.Item(i).innerText = "Diameter" Then
diametervalue = td.Item(i).innerText
diametervalue = Mid(diametervalue, 1, Len(diametervalue) - 3)
End If
If th.Item(i).innerText = "Thickness" Then
thicknessvalue = td.Item(i).innerText
thicknessvalue = Mid(thicknessvalue, 1, Len(thicknessvalue) - 3)
End If
If th.Item(i).innerText = "Shape" Then shapevalue = td.Item(i).innerText
If th.Item(i).innerText = "References" Then kmvalue = td.Item(i).innerText
If th.Item(i).innerText = "Value" Then coinvalue = td.Item(i).innerText
If th.Item(i).innerText = "Currency" Then currenvalue = td.Item(i).innerText
If th.Item(i).innerText = "Type" Then cointypevalue = td.Item(i).innerText

Next i
' MsgBox (currenvalue)
' MsgBox (cointypevalue)



' get description
Set h = html.body.getElementsByTagName("h3")
For i = 0 To h.Length - 1
Set e = h.Item(i).NextSibling

' get commemorative issue
If h.Item(i).innerText = "Commemorative issue" Then
' MsgBox ("found commemorative issue")
subjectvalue = e.innerText
End If


' get obverse
If h.Item(i).innerText = "Obverse" Then
' MsgBox ("found obverse")

Do
If InStr(e.innerText, "Lettering:") > 0 Then
' MsgBox ("legend found")
obverselegendvalue = e.innerText
obverselegendvalue = Mid(obverselegendvalue, 12)
If Asc(Mid(obverselegendvalue, 1, 1)) = 13 Then obverselegendvalue = Mid(obverselegendvalue, 2)
If Asc(Mid(obverselegendvalue, 1, 1)) = 10 Then obverselegendvalue = Mid(obverselegendvalue, 2)
If Asc(Mid(obverselegendvalue, 1, 1)) = 13 Then obverselegendvalue = Mid(obverselegendvalue, 2)
If Asc(Mid(obverselegendvalue, 1, 1)) = 13 Then obverselegendvalue = Mid(obverselegendvalue, 2)

' MsgBox (obverselegendvalue)
ElseIf InStr(e.innerText, "Translation:") > 0 Then
obverselegendvalue = obverselegendvalue + e.innerText
ElseIf InStr(e.innerText, "Engraver:") > 0 Then
obversedesignervalue = e.innerText
obversedesignervalue = Mid(obversedesignervalue, 11)
ElseIf e.nodeName = "P" Then
obversevalue = obversevalue + e.innerText
End If

Set e = e.NextSibling
Loop Until e.nodeName = "H3"

End If
 
' get reverse
If h.Item(i).innerText = "Reverse" Then
'MsgBox ("found reverse")


Do
If InStr(e.innerText, "Lettering:") > 0 Then
' MsgBox ("legend found")
reverselegendvalue = e.innerText
reverselegendvalue = Mid(reverselegendvalue, 12)
If Asc(Mid(reverselegendvalue, 1, 1)) = 13 Then reverselegendvalue = Mid(reverselegendvalue, 2)
If Asc(Mid(reverselegendvalue, 1, 1)) = 10 Then reverselegendvalue = Mid(reverselegendvalue, 2)
If Asc(Mid(reverselegendvalue, 1, 1)) = 13 Then reverselegendvalue = Mid(reverselegendvalue, 1)

' MsgBox (reverselegendvalue)
ElseIf InStr(e.innerText, "Translation:") > 0 Then
reverselegendvalue = reverselegendvalue + e.innerText
ElseIf InStr(e.innerText, "Engraver:") > 0 Then
reversedesignervalue = e.innerText
reversedesignervalue = Mid(reversedesignervalue, 11)
ElseIf e.nodeName = "P" Then
reversevalue = reversevalue + e.innerText
End If

Set e = e.NextSibling
Loop Until e.nodeName = "H3"

End If

' get edge
If h.Item(i).innerText = "Edge" Then
edgevalue = ""
' msgbox ("found edge")
Do
edgevalue = edgevalue + e.innerText

Set e = e.NextSibling
Loop Until e.nodeName <> "P"


End If

' no more
If h.Item(i).innerText = "Manage my collection" Then
' MsgBox ("Manage my collection, exiting for")
Exit For
End If

Next i


Set e = h.Item(0).NextSibling


' customize
' define which data should be pasted into the Excel sheet

' country
   ActiveSheet.Cells(ActiveCell.Row, country) = countryvalue

' coin
  ActiveSheet.Cells(ActiveCell.Row, coin) = coinvalue

' km
 'ActiveSheet.Cells(ActiveCell.Row, km) = kmvalue

' years issued
ActiveSheet.Cells(ActiveCell.Row, year) = yearvalue

' composition
ActiveSheet.Cells(ActiveCell.Row, metal) = metalvalue

' weight
ActiveSheet.Cells(ActiveCell.Row, weight) = weightvalue

' diameter
ActiveSheet.Cells(ActiveCell.Row, diameter) = diametervalue

' thickness
ActiveSheet.Cells(ActiveCell.Row, thickness) = thicknessvalue

' edge
ActiveSheet.Cells(ActiveCell.Row, edge) = edgevalue

' shape
ActiveSheet.Cells(ActiveCell.Row, shape) = shapevalue

' obverse
ActiveSheet.Cells(ActiveCell.Row, obverse) = obversevalue

' obverse legend
ActiveSheet.Cells(ActiveCell.Row, obverselegend) = obverselegendvalue

' obverse engraver
ActiveSheet.Cells(ActiveCell.Row, obversedesigner) = obversedesignervalue

' reverse
ActiveSheet.Cells(ActiveCell.Row, reverse) = reversevalue

' reverse legend
ActiveSheet.Cells(ActiveCell.Row, reverselegend) = reverselegendvalue

' reverse engraver
ActiveSheet.Cells(ActiveCell.Row, reversedesigner) = reversedesignervalue

' currency
ActiveSheet.Cells(ActiveCell.Row, curren) = currenvalue

' subject
ActiveSheet.Cells(ActiveCell.Row, subject) = subjectvalue


' end of customize



Beep
 End Sub