Myujth

So I found this vba code to check VAT number via Excel. But the link that they used in the code doesnt work anymore and need to be adjusted to this link http://ec.europa.eu/taxation_customs/vies/?locale=be

But if I change the link I also need to change other elements, but unfortunatly I am still a beginner with regards to coding.

Does anyone know what I need to change in order to get the following?
VatNumberCheckExcel

The vba code is currently this:

Sub test()
 Dim lrow As Long, data, obj As Object, i As Long, country, VATnum, webreply As String

 lrow = Cells(Rows.Count, 1).End(xlUp).Row
 If lrow = 1 Then Exit Sub

 If Range("a1") <> "VAT" Then Exit Sub

 data = Range("a1:d" & lrow)

 Set obj = CreateObject("MSXML2.XMLHTTP")

 For i = 2 To lrow
 If Len(data(i, 1)) > 2 Then
 country = Left(data(i, 1), 2)
 VATnum = Right(data(i, 1), Len(data(i, 1)) - 2)
 obj.Open "GET", "http://vatid.eu/check/" & country & "/" & VATnum & "/" & country & "/" & VATnum
 obj.send
 Do: DoEvents: Loop Until obj.ReadyState = 4
 webreply = obj.responsetext
 If InStr(webreply, "<error>") > 0 Then
 data(i, 2) = False
 Else
 data(i, 2) = Split(Split(webreply, "<valid>")(1), "</valid>")(0)
 data(i, 3) = Split(Split(webreply, "<name><![CDATA[")(1), "]]></name>")(0)
 data(i, 4) = Split(Split(webreply, "<address><![CDATA[")(1), "]]></address>")(0)
 End If
 End If
 Next

 obj.abort

 Range("a1:d" & lrow) = data

End Sub





Public Function VAT(rng As Range) As String
 With CreateObject("MSXML2.XMLHTTP")
 .Open "GET", "http://vatid.eu/check/" & Left(rng, 2) & "/" & Right(rng, Len(rng) - 2)
 .send
 Do: DoEvents: Loop Until .ReadyState = 4
 VAT = Split(Split(.responsetext, "<valid>")(1), "</valid>")(0)
 .abort
 End With
End Function

Thanks alot

The below seems to work for me, but you might need to change "Sheet1" to the name of the sheet where your data is located.

Option Explicit

Private Sub VerifyEUVatNumbers()

 Const EU_VIES_API_ENDPOINT As String = "http://ec.europa.eu/taxation_customs/vies/services/checkVatService"

 ' Change this to whatever your worksheet is called. I assume Sheet1
 With ThisWorkbook.Worksheets("Sheet1")

 Dim lastRow As Long
 lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

 .Range("B2:D" & lastRow).ClearContents ' Clear results from last time code was run

 Dim euVATnumbersToCheck() As Variant
 euVATnumbersToCheck = .Range("A2:D" & lastRow).Value2

 Dim countryCode As String
 Dim vatNumber As String
 Dim envelopeToSend As String
 Dim rowIndex As Long

 Dim webClient As MSXML2.ServerXMLHTTP60
 Set webClient = New MSXML2.ServerXMLHTTP60

 With webClient
 For rowIndex = LBound(euVATnumbersToCheck, 1) To UBound(euVATnumbersToCheck, 1)
 countryCode = VBA.Strings.Left$(euVATnumbersToCheck(rowIndex, 1), 2)
 vatNumber = VBA.Strings.Mid$(euVATnumbersToCheck(rowIndex, 1), 3)
 envelopeToSend = soapEnvelope(countryCode, vatNumber)

 .Open "POST", EU_VIES_API_ENDPOINT, True
 .send envelopeToSend
 .waitForResponse

 euVATnumbersToCheck(rowIndex, 2) = TextBetweenTwoDelimiters(.responseText, "<valid>", "</valid>")
 euVATnumbersToCheck(rowIndex, 3) = TextBetweenTwoDelimiters(.responseText, "<name>", "</name>")
 euVATnumbersToCheck(rowIndex, 4) = TextBetweenTwoDelimiters(.responseText, "<address>", "</address>")
 euVATnumbersToCheck(rowIndex, 4) = VBA.Strings.Replace(euVATnumbersToCheck(rowIndex, 4), VBA.Strings.Chr$(10), ", ", 1, -1, vbBinaryCompare)
 Next rowIndex
 End With

 .Range("A2").Resize(UBound(euVATnumbersToCheck, 1), UBound(euVATnumbersToCheck, 2)).Value2 = euVATnumbersToCheck

 End With
End Sub

Public Function TextBetweenTwoDelimiters(ByVal textToParse As String, ByVal firstDelimiter As String, ByVal secondDelimiter As String) as String
 Dim firstDelimiterIndex As Long
 firstDelimiterIndex = VBA.Strings.InStr(1, textToParse, firstDelimiter, vbBinaryCompare)

 If firstDelimiterIndex = 0 Then
 Exit Function
 Else
 firstDelimiterIndex = firstDelimiterIndex + Len(firstDelimiter) ' Assume we don't delimiter included
 End If

 Dim secondDelimiterIndex As Long
 secondDelimiterIndex = VBA.Strings.InStr(firstDelimiterIndex, textToParse, secondDelimiter, vbBinaryCompare)

 If secondDelimiterIndex = 0 Then
 Exit Function
 Else
 secondDelimiterIndex = secondDelimiterIndex ' Assume we don't delimiter included
 End If

 TextBetweenTwoDelimiters = VBA.Strings.Mid$(textToParse, firstDelimiterIndex, secondDelimiterIndex - firstDelimiterIndex)
End Function

Private Function soapEnvelope(ByVal countryCode As String, ByVal vatNumber As String) As String
 ' Give this function a country code and VAT Number.
 ' It will return an envelope that can be sent in the request's body

 Dim outputEnvelope As String
 outputEnvelope = "<s11:Envelope xmlns:s11='http://schemas.xmlsoap.org/soap/envelope/'>" & _
 "<s11:Body>" & _
 "<tns1:checkVat xmlns:tns1='urn:ec.europa.eu:taxud:vies:services:checkVat:types'>" & _
 "<tns1:countryCode>" & countryCode & "</tns1:countryCode>" & _
 "<tns1:vatNumber>" & vatNumber & "</tns1:vatNumber>" & _
 "</tns1:checkVat>" & _
 "</s11:Body>" & _
 "</s11:Envelope>"

 soapEnvelope = outputEnvelope
End Function

Some things to note:

• I took the SOAP envelope from one of the existing PHP implementations
  on GitHub (I've since closed that particular browser tab, otherwise
  would include the link in my answer).


• Instead of parsing server's
  response as an XML document, I just parse it as a string (not good,
  but the returned resource is pretty small).


• Code assumes
  everything will be successful. If the request times out or an
  error message is returned, the code will likely throw an error (if it does not know how to handle it)


• From the technical resources/documentation available on the EC's own website
  (e.g. WSDL and FAQ), it seems that there is no central
  database (your request goes to their server, then their server
  requests the information from the relevant country/member state's
  database).


• The usual quota/usage stipulations (governing the consumption of
  any service/API) are in place. If they receive too many requests from
  a given IP within a short space of time or too many requests which
  yield invalid EU VAT numbers, they may suspect misuse of their service and blacklist
  your IP.

This is what I start off with:

This is what I get after the code:

Largely based on this answer. Only changed the NextSibling part to getting the x'th td tag:

Sub getData()

'~~~~Variable declaration~~~~'
Dim IE As Object
Dim country As Object
Dim num As Object
Dim btn As Object
Dim tlb As Object, td As Object

Set IE = CreateObject("InternetExplorer.Application")

IE.Visible = False
IE.navigate "http://ec.europa.eu/taxation_customs/vies/?locale=en"

'Wait till page is loaded
Do While IE.readystate <> 4
 DoEvents
Loop


Set country = IE.document.getElementById("countryCombobox")
country.Value = "FR" 'set the value for Member state


'Pause the code for 1 sec
Application.Wait Now + TimeSerial(0, 0, 1)

'
Set num = IE.document.getElementById("number")
num.Value = "27435044714" 'set the Vat number


Application.Wait Now + TimeSerial(0, 0, 1)


Set btn = IE.document.getElementById("submit")
btn.Click ' click the verify button

'Wait till page is loaded
Do While IE.readystate <> 4: DoEvents: Loop

'Pause the code for 5 sec
 Application.Wait Now + TimeSerial(0, 0, 5)

 Set tbl = IE.document.getElementById("vatResponseFormTable")

 numb_spans = tbl.getElementsByTagName("td").Length
 MsgBox (tbl.getElementsByTagName("td")(0).innerText)
 pos = InStr(1, tbl.getElementsByTagName("td")(0).innerText, "valid VAT")
 If pos > 0 Then
 Cells(2, 2) = True
 Cells(2, 3) = tbl.getElementsByTagName("td")(10).innerText
 Cells(2, 4) = tbl.getElementsByTagName("td")(12).innerText
 Else
 Cells(2, 2) = False
 End If
 IE.Quit
 Set IE = Nothing
 End Sub