Copy Data from Web page and paste into Excel - excel

Question

I have been trying to scrape the web data using EXCEL VBA. Below code paste the date from excel to wen then initiated the submit button to go to the result page. which looks like this:
I want to copy and paste the first and the second line into excel like this:
if any individual gets first dose then put details of first dose, and return empty for the second dose if its empty. If both dose are not available then return empty for both.
I am not able to develop this last thing and struggling since couple of hours to achieve this (copy data and paste into excel)
it would required a ID number and date to submit for the result that i can provide in comments. I have been using following code to accomplish this your help will be much appreciated.
Option Explicit
Sub Newfunction()
Const Url As String = ""
Dim LogData As Worksheet
Set LogData = ThisWorkbook.Worksheets("Sheet1")
Dim IdNumber As String
Dim openDate As Date
IdNumber = LogData.Cells(3, "A").Value
openDate = LogData.Cells(3, "B").Value
Set LogData = Nothing
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Navigate Url
Do While .Busy Or .ReadyState <> 4
DoEvents
Loop
.Visible = True
Dim ieDoc As Object
Set ieDoc = .Document
End With
'Enter the CNIC
Dim IDdata As Object
Set IDdata = ieDoc.getElementById("checkEligibilityForm:cnic")
If Not IDdata Is Nothing Then IDdata.Value = IdNumber
Set IDdata = Nothing
'Enter Date
Dim puttdate As Object
Set puttdate = ieDoc.getElementById("checkEligibilityForm:issueDate_input")
If Not puttdate Is Nothing Then puttdate.Value = Format(openDate, "dd-mm-yyyy")
Set puttdate = Nothing
'Answering the captcha question
'Split the innerText to string array to determine the equation
Dim captchaQns As Object
Set captchaQns = ieDoc.getElementsByClassName("submit__generated")(0)
If Not captchaQns Is Nothing Then
Dim mathEq() As String
mathEq = Split(captchaQns.innerText, " ")
Set captchaQns = Nothing
'mathEq(0) = first number
'mathEq(1) = math operator
'mathEq(2) = second number
If IsNumeric(mathEq(0)) Then
Dim firstNum As Long
firstNum = CLng(mathEq(0))
If IsNumeric(mathEq(2)) Then
Dim secondNum As Long
secondNum = CLng(mathEq(2))
'Select Case statement used here in case you encounter other form of math question (e.g. - X /), expand cases to cater for other scenario
Dim mathAnswer As Long
Select Case mathEq(1)
Case "+": mathAnswer = firstNum + secondNum
End Select
End If
End If
If mathAnswer <> 0 Then
'Enter the answer to the box
Dim captchaAns As Object
Set captchaAns = ieDoc.getElementsByClassName("submit__input")(0)
If Not captchaAns Is Nothing Then captchaAns.Value = mathAnswer
Set captchaAns = Nothing
'Get the submit button element, remove "disabled" attribute to allow clicking
Dim submitBtn As Object
Set submitBtn = ieDoc.getElementsByName("checkEligibilityForm:j_idt79")(0)
submitBtn.removeAttribute "disabled"
submitBtn.Click
Set submitBtn = Nothing
End If
End If
Dim tbls, tbl, trs, tr, tds, td, r, c
Set tbl = ie.Document.getElementsByTagName("table")(0)
Set trs = tbl.getElementsByTagName("tr")
For r = 0 To trs.Length - 1
Set tds = trs(r).getElementsByTagName("tr")
'if no <td> then look for <th>
If tds.Length = 0 Then Set tds = trs(r).getElementsByTagName("td")
For c = 0 To tds.Length - 1
ActiveSheet.Range("C4").Offset(r, c).Value = tds(c).innerText
Next c
Next r
End Sub

Answer 1

Try this:
It will enter the data into Range("C4:F4") for first dose and Range("G4:J4") for second dose.
Sub Newfunction()
Const Url As String = "https://nims.nadra.gov.pk/nims/certificate"
Dim LogData As Worksheet
Set LogData = ThisWorkbook.Worksheets("Sheet1")
Dim lastRow As Long
lastRow = LogData.Range("A" & Rows.Count).End(xlUp).Row
Dim currentRow As Long
For currentRow = 3 to lastRow
Dim IdNumber As String
Dim openDate As Date
IdNumber = LogData.Cells(currentRow, 1).Value
openDate = LogData.Cells(currentRow, 2).Value
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
With ie
.navigate Url
Do While .Busy Or .readyState <> 4
DoEvents
Loop
.Visible = True
Dim ieDoc As Object
Set ieDoc = .document
End With
'Enter the CNIC
Dim IDdata As Object
Set IDdata = ieDoc.getElementById("checkEligibilityForm:cnic")
If Not IDdata Is Nothing Then IDdata.Value = IdNumber
Set IDdata = Nothing
'Enter Date
Dim puttdate As Object
Set puttdate = ieDoc.getElementById("checkEligibilityForm:issueDate_input")
If Not puttdate Is Nothing Then puttdate.Value = Format(openDate, "dd-mm-yyyy")
Set puttdate = Nothing
'Answering the captcha question
'Split the innerText to string array to determine the equation
Dim captchaQns As Object
Set captchaQns = ieDoc.getElementsByClassName("submit__generated")(0)
If Not captchaQns Is Nothing Then
Dim mathEq() As String
mathEq = Split(captchaQns.innerText, " ")
Set captchaQns = Nothing
'mathEq(0) = first number
'mathEq(1) = math operator
'mathEq(2) = second number
If IsNumeric(mathEq(0)) Then
Dim firstNum As Long
firstNum = CLng(mathEq(0))
If IsNumeric(mathEq(2)) Then
Dim secondNum As Long
secondNum = CLng(mathEq(2))
'Select Case statement used here in case you encounter other form of math question (e.g. - X /), expand cases to cater for other scenario
Dim mathAnswer As Long
Select Case mathEq(1)
Case "+": mathAnswer = firstNum + secondNum
End Select
End If
End If
Erase mathEq
If mathAnswer <> 0 Then
'Enter the answer to the box
Dim captchaAns As Object
Set captchaAns = ieDoc.getElementsByClassName("submit__input")(0)
If Not captchaAns Is Nothing Then captchaAns.Value = mathAnswer
Set captchaAns = Nothing
'Get the submit button element, remove "disabled" attribute to allow clicking
Dim submitBtn As Object
Set submitBtn = ieDoc.getElementsByName("checkEligibilityForm:j_idt79")(0)
submitBtn.removeAttribute "disabled"
submitBtn.Click
Set submitBtn = Nothing
End If
End If
With ie
Do While .Busy Or .readyState <> 4
DoEvents
Loop
Set ieDoc = .document
End With
Dim resultTbl As Object
Set resultTbl = ieDoc.getElementsByTagName("table")
If resultTbl.Length <> 0 Then
Dim resultRows As Object
Set resultRows = resultTbl(0).getElementsByTagName("tr")
If resultRows.Length > 1 Then
'Get the 2nd row (1st row is header so ignore)
Dim firstDose As Object
Set firstDose = resultRows(1).getElementsByTagName("td")
LogData.Cells(currentRow, 3).Value = firstDose(0).innerText
LogData.Cells(currentRow, 4).Value = firstDose(1).innerText
LogData.Cells(currentRow, 5).Value = firstDose(2).innerText
LogData.Cells(currentRow, 6).Value = firstDose(3).innerText
Set firstDose = Nothing
'If there are totals of 3 TR elements then there are 2nd dose
If resultRows.Length = 3 Then
Dim secondDose As Object
Set secondDose = resultRows(2).getElementsByTagName("td")
LogData.Cells(currentRow, 7).Value = secondDose(0).innerText
LogData.Cells(currentRow, 8).Value = secondDose(1).innerText
LogData.Cells(currentRow, 9).Value = secondDose(2).innerText
LogData.Cells(currentRow, 10).Value = secondDose(3).innerText
Set secondDose = Nothing
End If
'Else
'Do something here if there is only a header row i.e. no dose (assumption)
End If
Set resultRows = Nothing
End If
Set resultTbl = Nothing
Set ieDoc = Nothing
ie.Quit 'Remove if you don't want to close IE
Set ie = Nothing 'Remove if you don't want to close IE
Next currentRow
Set LogData = Nothing
End Sub