Resources
  • Home
  • December-Chrono
  • Psalm136Personalized
  • ExcelResources
    • 99PublicFunctions
    • aDelimitedCodeTemplate
    • aCodeTemplate
    • aBetter_Code_Template
    • ApplyFormulaValue
    • ArrayPublic
    • ArrayMatchCopyRow
    • Capitalization
    • Colors
    • DataTypes
    • DeleteRows
    • Filter
    • FormatStandard
    • Forms
    • Grid
    • Headers
    • ImageScrape
    • InputBox
  • ExcelResources2
    • Like
    • List Review
    • MatchAndReturn
    • mod_Import
    • Numbers
    • PDF_Parse
    • RandomGenerator
    • iRe1
    • Rept
    • RelatedItemsLIst
    • RomanNumerals
    • SheetSplitter
    • Sort
    • Split Method
    • String_DataType
    • TabDelimited
    • Tab_InsertNew_or_ClearExisting
    • Unique_List
      • UniqueLIsts_FilterMethod
  • Excelresources_Files
    • FileLists
    • FileTextParse
    • Folders
  • excelresources_WebScrape
    • CreateList_1-Href_2-Jpg
    • TableData_Load_PlugPlay
    • CreateList_MultiPage_Image_Link
      • ImageDownload_WebLink_List
    • TableData_Load_ClassDiv
    • TableData_Load_ClassSpan
  • Houseboat Vacation
  • At the Foot of the King
  • Devotions
  • Mentoring
  • Inspirational Stories
    • Vacuum Lifting
  • Job Help
  • Resources
    • MS
    • Florida History
  • Contact
  • Heroscape
    • Fish
    • Playstation
  • You Tube Videos
  • House
    • Tiny Houses
    • Backyards
  • CampingResources
    • CampingLand
    • LED Throwies
  • Interesting
  • Recipes
  • Xbox
  • Skydiving
  • ReadingPlan-5Year
  • Desoto
  • BibleStudy
  • HurricaneIrma
  • Home
  • December-Chrono
  • Psalm136Personalized
  • ExcelResources
    • 99PublicFunctions
    • aDelimitedCodeTemplate
    • aCodeTemplate
    • aBetter_Code_Template
    • ApplyFormulaValue
    • ArrayPublic
    • ArrayMatchCopyRow
    • Capitalization
    • Colors
    • DataTypes
    • DeleteRows
    • Filter
    • FormatStandard
    • Forms
    • Grid
    • Headers
    • ImageScrape
    • InputBox
  • ExcelResources2
    • Like
    • List Review
    • MatchAndReturn
    • mod_Import
    • Numbers
    • PDF_Parse
    • RandomGenerator
    • iRe1
    • Rept
    • RelatedItemsLIst
    • RomanNumerals
    • SheetSplitter
    • Sort
    • Split Method
    • String_DataType
    • TabDelimited
    • Tab_InsertNew_or_ClearExisting
    • Unique_List
      • UniqueLIsts_FilterMethod
  • Excelresources_Files
    • FileLists
    • FileTextParse
    • Folders
  • excelresources_WebScrape
    • CreateList_1-Href_2-Jpg
    • TableData_Load_PlugPlay
    • CreateList_MultiPage_Image_Link
      • ImageDownload_WebLink_List
    • TableData_Load_ClassDiv
    • TableData_Load_ClassSpan
  • Houseboat Vacation
  • At the Foot of the King
  • Devotions
  • Mentoring
  • Inspirational Stories
    • Vacuum Lifting
  • Job Help
  • Resources
    • MS
    • Florida History
  • Contact
  • Heroscape
    • Fish
    • Playstation
  • You Tube Videos
  • House
    • Tiny Houses
    • Backyards
  • CampingResources
    • CampingLand
    • LED Throwies
  • Interesting
  • Recipes
  • Xbox
  • Skydiving
  • ReadingPlan-5Year
  • Desoto
  • BibleStudy
  • HurricaneIrma
Connect on Facebook

Load Table Data
<class>
<div>

When a Website has data arranged in some type of table format:

Picture

...But you would like it to look something like this (In Excel):

Picture

Check the source code for Labels to use (and adapt code as needed)

1) Create a string that contains the Headers
2) Create a list of links that contain the individual pages
3) Create a loop that calls the function and loads data for each row based on the Column A value
4) Each website is different - code looks at things like:
     a) Class Labels / Values (["my_title">"], ["my_data">""])
     b) Close Tags (</div>, </a>)


Call the function using this method:

Picture

Here is a sample of the code:
(Also Requires: RestringHTMLLinks)

Function WebScrape_ProductPage_FB(MyTab As Variant, MyRow As Variant, MyDumpCol As Variant, MyLinkCol As Variant)

'Enum READYSTATE
'    READYSTATE_UNINITIALIZED = 0
'    READYSTATE_LOADING = 1
'    READYSTATE_LOADED = 2
'    READYSTATE_INTERACTIVE = 3
'    READYSTATE_COMPLETE = 4
'End Enum


Dim sWebLink As String

Dim iLoop As Long, sQuote As String, sTempA As String, sTempB As String, sTempC As String, sTempD As String, sTempE As String, sTempF As String, sTempG As String
Dim iTempA As Long, iTempB As Long, iTempC As Long, iTempD As Long, iTempE As Long, iTempF As Long, iTempG As Long
Dim iCloseTagA As Long, iStartVal As Long
Dim sCloseAddr As String, sHref As String, sAmp As String, sDelimiter As String, sMarkStart As String

Dim iUboundR As Long, iUboundC As Long, aDump() As Variant
Dim Ws1 As Long, iNextRow As Long
Dim sHeader As String, aSplitMe As Variant
Dim sClassLabel As String, sClassValue As String, sCloseTag As String
Dim aHeaders() As Variant

'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Erase aDump: Erase aHeaders
Ws1 = Worksheets(MyTab).Index
iNextRow = MyRow
sQuote = """"
sWebLink = Worksheets(Ws1).Cells(iNextRow, MyLinkCol) '"https://www.fa

'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
        'create the markers for the strings:
        sClassLabel = "tech_title" & sQuote & ">"
        sClassValue = "tech_data" & sQuote & ">"
        sCloseTag = "</div>"
        sCloseAddr = "</a>"
        sHref = "href"
        sAmp = " &amp;"
        sDelimiter = "|"
        sMarkStart = ">"
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO

'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
sHeader = "Product Number^Brand^Application^Uses^Width^Colors^Vertical Repeat^Horizontal Repeat^Railroaded^Fire Codes^Double Rubs^Content^Finish^Backing^Categories^Design Types^Scale^Cleaning Codes^Collection^Date Booked^Book^Country^Additional Product Notes^"

    'Split String (Populate Public Array: Row1-Headers)
    aSplitMe = Split(sHeader, "^")

'AAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    iUboundC = Len(sHeader) - Len(Replace(sHeader, "^", "", , , vbTextCompare))
    aHeaders = Range(Worksheets(Ws1).Cells(iNextRow, MyDumpCol).Address, Worksheets(Ws1).Cells(iNextRow, MyDumpCol + iUboundC).Address)
'AAAAAAAAAAAAAAAAAAAAAAAAAAAAA

       'Load All non blank values into the Array (Header Position)
    For iLoop = LBound(aSplitMe) To UBound(aSplitMe)
        If aSplitMe(iLoop) <> "" Then aHeaders(1, iLoop + 1) = aSplitMe(iLoop)
    Next iLoop
'===================================================================================================
Worksheets(Ws1).Select
'''GoTo gArrayMemoryCleanupOnly
Set Destination = Range(Worksheets(Ws1).Cells(1, MyDumpCol).Address)
Destination.Resize(UBound(aHeaders, 1), UBound(aHeaders, 2)).Value = aHeaders
'===================================================================================================
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''GoTo gMemoryCleanup

    
'to refer to the running copy of Internet Explorer
    Dim oWebBrowser As InternetExplorer

'to refer to the HTML document returned
    Dim sHTML As HTMLDocument

'open Internet Explorer in memory, and go to website
    Set oWebBrowser = New InternetExplorer
    oWebBrowser.Visible = False
    oWebBrowser.navigate sWebLink '"https://www.fa

'Wait until IE is done loading page
    Do While oWebBrowser.READYSTATE <> READYSTATE_COMPLETE
        Application.StatusBar = "Trying to go to website ..."
        DoEvents
    Loop

'show text of HTML document returned
    Set sHTML = oWebBrowser.document
    sTempA = sHTML.DocumentElement.innerHTML

    'remove the carriage returns:
    sTempA = Replace(sTempA, Chr(13), "", , , vbTextCompare)
    sTempA = Replace(sTempA, Chr(10), "", , , vbTextCompare)
    
'AAAAAAAAAAAAAAAAAAAAAAAAAAAAA
    iUboundR = Len(sTempA) - Len(Replace(sTempA, "src=", "", , , vbTextCompare))
    aDump = Range(Worksheets(Ws1).Cells(iNextRow, MyDumpCol).Address, Worksheets(Ws1).Cells(iNextRow, MyDumpCol + iUboundC).Address)
'AAAAAAAAAAAAAAAAAAAAAAAAAAAAA

'Initiate the loop
    iTempA = 1
    Application.StatusBar = "Reviewing the HTML string"

'Review the HTML String - start over after setting the iTempA variable
gReviewHTMLstring:
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    'Provide escape route during testing:
    DoEvents
        
    'Create numeric checks for string positions
    iTempB = InStr(iTempA, sTempA, sClassLabel, vbTextCompare)
    iTempC = InStr(iTempB + 1, sTempA, sCloseTag, vbTextCompare)
    iTempD = InStr(iTempC + 1, sTempA, sClassValue, vbTextCompare)
    iTempE = InStr(iTempD + 1, sTempA, sCloseTag, vbTextCompare)
        
        'Just in case values:
        iCloseTagA = InStr(iTempB, sTempA, sCloseAddr) '"</a>")
        iStartVal = InStrRev(sTempA, ">", iCloseTagA - 1, vbTextCompare)
        
gTestForContinue:
    If iTempB = 0 Or iTempC = 0 Or iTempD = 0 Or iTempE = 0 Then GoTo gFinishedWithReview
    If iTempC > iTempD Then MsgBox "Error: Mid function not available due to mismatched mid/end values"
    If iTempD > iTempE Then MsgBox "Error: Mid function not available due to mismatched mid/end values"
    
'YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY
'YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY

gExtractData:
    'Extract data
        'Extract the Label

        sTempB = Mid(sTempA, iTempB, iTempC - iTempB)
        sTempB = Replace(sTempB, sClassLabel, "", , , vbTextCompare)
        
        'Extract the Value
        sTempC = Mid(sTempA, iTempD, iTempE - iTempD)
            If InStr(1, sTempC, sHref, vbTextCompare) > 0 Then                                                                  'sHref = "href"
                If iCloseTagA < iTempE And iStartVal > iTempB Then
                    sTempC = RestringHTMLLinks(Replace(sTempC, sClassValue, "", , , vbTextCompare), sCloseAddr, sDelimiter, sMarkStart)
                Else
                    sTempC = ""
                End If
            End If
        sTempC = Replace(sTempC, sClassValue, "", , , vbTextCompare)
        If InStr(1, sTempC, sAmp, vbTextCompare) > 0 Then sTempC = Replace(sTempC, sAmp, " and", , , vbTextCompare)           'sAmp = "&amp;"
        sTempC = Trim(sTempC)

gCheckForMatchingHeader:
    iTempG = 0
    
    'check to see if the Label matches a correct Header value
    For iLoop = LBound(aDump, 2) To UBound(aDump, 2)
        If UCase(sTempB) = UCase(aHeaders(1, iLoop)) Then
            iTempG = iLoop
            GoTo gMatchMadeDoSomething
        End If
    Next iLoop
    
gMatchMadeDoSomething:
    'Test if Col Position Defined
    If iTempG = 0 Then GoTo gIncrementStartSearchPosition
    
    'populate Array
        Application.StatusBar = "Processing a Match: " & iNextRow & " | " & sTempB & "(" & Left(sTempC, 50) & ")"
        aDump(1, iTempG) = sTempC
    GoTo gIncrementStartSearchPosition:
    
   
gIncrementStartSearchPosition:
    iTempA = InStr(iTempD + 1, sTempA, sClassLabel, vbTextCompare)
        'A:Stop the process - no more matches
            If iTempA = 0 Then GoTo gFinishedWithReview
        'B: Check the remainder of the string - more matches available
            GoTo gReviewHTMLstring
    
    
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

gFinishedWithReview:
    'Dump the results:
'===================================================================================================

Worksheets(Ws1).Select
Set Destination = Range(Worksheets(Ws1).Cells(iNextRow, MyDumpCol).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'===================================================================================================

GoTo gMemoryCleanup

gMemoryCleanup:
'(Close down oWebBrowser) / (Reset status bar)
    oWebBrowser.Quit
    Set oWebBrowser = Nothing
    Application.StatusBar = ""

gArrayMemoryCleanupOnly:
'Release Array memory
    Erase aDump: Erase aHeaders

MsgBox "Done"
End Function
Function RestringHTMLLinks(myInput As Variant, myReDeliminate As Variant, myNewDelimiter As Variant, myStartChar As Variant) As String
Dim sInput As String, sPreDel As String, sPostDel As String, sStartChar As String
Dim sTempInput As String, sTempPreDel As String, sTempPostDel As String
Dim aSplitMe As Variant, sConcat As String, iCount As Long, iLoop As Long
Dim iLeft As Long

sInput = myInput
sPreDel = myReDeliminate
sPostDel = myNewDelimiter
sStartChar = myStartChar

'Convert for Splitting (replace old delimiter with new one)
sInput = Replace(sInput, sPreDel, sPostDel, , , vbTextCompare)

'Create Array for looping:
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
    'Split String (Populate Public Array: Row1-Headers)
    aSplitMe = Split(sInput, sPostDel)
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS

    For iLoop = LBound(aSplitMe) To UBound(aSplitMe)
        
        'Create a marker for the first character position
        iLeft = InStr(1, aSplitMe(iLoop), sStartChar, vbTextCompare)
        
        'Route based on if marker was found:
        If iLeft > 0 Then GoTo gExtractValue
        GoTo gNextLoop
        
gExtractValue:
    'add the value to the string being returned
    sConcat = sConcat & sPostDel & Right(aSplitMe(iLoop), Len(aSplitMe(iLoop)) - iLeft)
    GoTo gNextLoop
    
gNextLoop:
    Next iLoop

gFinishedLoadResults:
RestringHTMLLinks = sConcat
If Left(RestringHTMLLinks, 1) = sPostDel Then RestringHTMLLinks = Right(RestringHTMLLinks, Len(RestringHTMLLinks) - 1)

End Function
Powered by Create your own unique website with customizable templates.
  • Home
  • December-Chrono
  • Psalm136Personalized
  • ExcelResources
    • 99PublicFunctions
    • aDelimitedCodeTemplate
    • aCodeTemplate
    • aBetter_Code_Template
    • ApplyFormulaValue
    • ArrayPublic
    • ArrayMatchCopyRow
    • Capitalization
    • Colors
    • DataTypes
    • DeleteRows
    • Filter
    • FormatStandard
    • Forms
    • Grid
    • Headers
    • ImageScrape
    • InputBox
  • ExcelResources2
    • Like
    • List Review
    • MatchAndReturn
    • mod_Import
    • Numbers
    • PDF_Parse
    • RandomGenerator
    • iRe1
    • Rept
    • RelatedItemsLIst
    • RomanNumerals
    • SheetSplitter
    • Sort
    • Split Method
    • String_DataType
    • TabDelimited
    • Tab_InsertNew_or_ClearExisting
    • Unique_List
      • UniqueLIsts_FilterMethod
  • Excelresources_Files
    • FileLists
    • FileTextParse
    • Folders
  • excelresources_WebScrape
    • CreateList_1-Href_2-Jpg
    • TableData_Load_PlugPlay
    • CreateList_MultiPage_Image_Link
      • ImageDownload_WebLink_List
    • TableData_Load_ClassDiv
    • TableData_Load_ClassSpan
  • Houseboat Vacation
  • At the Foot of the King
  • Devotions
  • Mentoring
  • Inspirational Stories
    • Vacuum Lifting
  • Job Help
  • Resources
    • MS
    • Florida History
  • Contact
  • Heroscape
    • Fish
    • Playstation
  • You Tube Videos
  • House
    • Tiny Houses
    • Backyards
  • CampingResources
    • CampingLand
    • LED Throwies
  • Interesting
  • Recipes
  • Xbox
  • Skydiving
  • ReadingPlan-5Year
  • Desoto
  • BibleStudy
  • HurricaneIrma