SHARE
TWEET

HTML Extract via VBA

a guest Jan 18th, 2019 54 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. '##################################################################################################
  2. '################## Variables #####################################################################
  3. '##################################################################################################
  4. Public http             As New XMLHTTP60
  5. Public HTML             As New HTMLDocument
  6. Public lnk              As String
  7. Public innertext        As String
  8. Public r, I, rw, erw    As Long
  9. Public nme              As String
  10.  
  11. Public Results          As Object
  12. Public itm, itm2        As Object
  13. Public nxt              As HTMLButtonElement
  14. Public tmNewTime        As Date
  15.  
  16. Sub get_data()
  17.  
  18.     'Clear Data
  19.     sh01.Rows("2:1048576").Delete Shift:=xlUp
  20.    
  21.     'Application.ScreenUpdating = True
  22.     Application.ScreenUpdating = False
  23.    
  24.     rw = 1
  25.     erw = z_sh01.Cells(z_sh01.Rows.Count, 1).End(xlUp).Row
  26.  
  27. '##################################################################################################
  28. '################## Loop Starts ###################################################################
  29. '##################################################################################################
  30.    
  31.     Do Until rw > erw
  32.      
  33.         min = Round((erw - rw) / 60, 0)
  34.         tmNewTime = DateAdd("n", min, Time())
  35.        
  36.         Application.StatusBar = "Checking item " & rw - 1 & " of " & erw - 1 & " (" & Format(rw / erw, "0%") & "), ETA " & Format(tmNewTime, "h:mm am/pm")
  37.  
  38. '################## Open Website ##################################################################
  39.  
  40.         lnk = z_sh01.Cells(rw, 1)
  41.  
  42.         On Error Resume Next
  43.         With http
  44.             .Open "GET", lnk, False
  45.             .send
  46.             HTML.body.innerHTML = .responseText
  47.         End With
  48.         On Error GoTo 0
  49.        
  50. '################## Populate ######################################################################
  51.              
  52.         r = sh01.Cells(sh01.Rows.Count, 1).End(xlUp).Row + 1
  53.        
  54.         On Error Resume Next
  55.             nme = HTML.getElementsByClassName("pdp__productName")(0).innertext
  56.             If nme <> "" Then pop
  57.             nme = ""
  58.         On Error GoTo 0
  59.        
  60.         sh01.Rows(r).WrapText = False
  61.         r = sh01.Cells(sh01.Rows.Count, 1).End(xlUp).Row + 1
  62.        
  63.         rw = rw + 1
  64.            
  65.         DoEvents
  66.  
  67.     Loop
  68.    
  69. '##################################################################################################
  70. '################## Loop Ends #####################################################################
  71. '##################################################################################################
  72.  
  73.     sh01.Cells.WrapText = False
  74.     sh01.Rows(1).WrapText = True
  75.  
  76.     sh01.Cells(2, 4).Select
  77.         Application.DisplayAlerts = False
  78.         svas = "C:\Users\Ian Greathead\Google Drive\data scrape\SKU\Superdrug.xlsx"
  79.         Sheets("Superdrug").Copy
  80.         ActiveWorkbook.SaveAs Filename:=svas, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  81.         ActiveWorkbook.Close
  82.     Application.DisplayAlerts = True
  83.    
  84.     sh01.Select
  85.    
  86.     ThisWorkbook.Saved = True
  87.     Application.Quit
  88.    
  89. End Sub
  90.  
  91. Sub pop()
  92.  
  93.     On Error Resume Next
  94.         sh01.Cells(r, 1) = z_sh01.Cells(rw, 2)                                              'shop sku
  95.         sh01.Cells(r, 2) = "IGSD" & z_sh01.Cells(rw, 2)                                     'our sku
  96.         sh01.Cells(r, 3) = nme                                                              'product name
  97.         sh01.Cells(r, 4) = HTML.getElementsByClassName("pricing__now")(0).outerText         'product price
  98.         sh01.Cells(r, 4) = HTML.getElementsByClassName("pricing__now")(0).innertext
  99.         sh01.Cells(r, 4) = HTML.getElementsByClassName("pricing__now")(0).Value
  100.         sh01.Cells(r, 5) = Int((20 - 1 + 1) * Rnd + 1)                                      'product stock
  101.         sh01.Cells(r, 6) = lnk                                                              'product URL
  102.         sh01.Rows(r).WrapText = False
  103.     On Error GoTo 0
  104.  
  105. End Sub
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top