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

Table Load:
Label(str[open] str[close])
Value(str[open] str[close])

Assume that a table is split into 2 sets of data: Labels/Values

Set strings to mark the beginning and end of each of the 2 data sets, then extract what is between them.

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

'to refer to the HTML document returned
    Public sHTML As HTMLDocument
    
Sub Call_WebScrape_LoadIndividualSKU()
Dim Ws1 As Long, iRe1 As Long, R1 As Long, iColLink As Long, iColDump As Long, iLoop As Long

'Create a web browser (hidden)
Set oWebBrowser = New InternetExplorer
oWebBrowser.Visible = True

Ws1 = Worksheets("").Index
iRe1 = 5
iColLink = 2
iColDump = 5

For iLoop = 7 To 75
    Call WebScrape_LoadIndividualSKU(Ws1, iLoop, iColLink, iColDump)
Next iLoop

oWebBrowser.Quit
Set oWebBrowser = Nothing

MsgBox "Finished"
End Sub


Function WebScrape_LoadPageTable(myWS As Variant, myLoadRow As Variant, myColLink As Variant, myColDump As Variant)

Dim iLoadRow As Long, iColLink As Long, iColDump As Long

Dim sWebLink As String

Dim iLoop As Long, 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, aHeaders() As Variant, 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
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Erase aHeaders: Erase aDump
Ws1 = Worksheets(myWS).Index
iNextRow = 1
iColLink = myColLink
iColDump = myColDump
iLoadRow = myLoadRow


sWebLink = Worksheets(Ws1).Cells(iLoadRow, iColLink)

'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
        'create the markers for the strings:

        sHref = "href"
        sAmp = " &"
        sDelimiter = "|"
        sMarkStart = ">"
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO

Const sQuote As String = """"

Const sLabelOpen As String = "***" & sQuote & ">"
Const sLabelClose As String = "</div>"

Const sValueOpen As String = "***" & sQuote & ">"
Const sValueClose As String = "</div>"

Const sReplaceExtra1 As String = "</div>"
Const sBonusOpen1 As String = ***" & sQuote & ">"
Const sBonusClose1 As String = "</p>"

Dim iLabelO As Long, iLabelC As Long
Dim iValueO As Long, iValueC As Long
Dim iBonusO1 As Long, iBonusC1 As Long

Dim sBlockTemp As String
Dim sLabelTemp As String
Dim sValueTemp As String

Dim iCharA As Long

Dim sLO As String, sLC As String
Dim sVO As String, sVC As String

Dim sBlockOpen As String, iBlockO As Long, iBlockC As Long
sBlockOpen = "<div class=" & sQuote & "***" & sQuote & ">"


'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS

sHeader = "p:^n:^w:^b:^c:^fc:^pr:^wd:^f:^or:^us:^dy:^ae:^ca:^&^"

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

'AAAAAAAAAAAAAAAAAAAAAAAAAAAAA
Worksheets(Ws1).Select
    iUboundC = Len(sHeader) - Len(Replace(sHeader, "^", "", , , vbTextCompare))
    aHeaders = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(1, iUboundC).Address)
    aDump = Range(Worksheets(Ws1).Cells(iLoadRow, iColDump), Worksheets(Ws1).Cells(iLoadRow, iColDump + 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(iNextRow, iLoop + 1) = aSplitMe(iLoop)
    Next iLoop
'===================================================================================================
Worksheets(Ws1).Select
Set Destination = Range(Worksheets(Ws1).Cells(1, iColDump).Address)
Destination.Resize(UBound(aHeaders, 1), UBound(aHeaders, 2)).Value = aHeaders
'===================================================================================================
'SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS
    
'(DO NOT open Internet Explorer)(Use version in memory), and go to website

    'Set oWebBrowser = New InternetExplorer
    'oWebBrowser.Visible = False

    
    oWebBrowser.navigate sWebLink '"https://www.fabricut.com/fabric/8872903/concert/mist"

'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)
    sTempA = Replace(sTempA, vbTab, "", , , vbTextCompare)


'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
gStartReviewingHTMLstring:
DoEvents

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'Reset to the first character position every time a new page # loads:

iCharA = 1

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

gRepeatDoUntilLoop:
    Do Until iCharA = 0
    'parse out the data
    DoEvents
    
gResetTempStrings:
    sBlockTemp = ""
    sLabelTemp = ""
    sValueTemp = ""
'*********************************************************************************************
        
gGetStartOfNextBlock:
iBlockO = InStr(iCharA, sTempA, sBlockOpen, vbTextCompare)

'LABEL: @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
gExtractLabel:
    iLabelO = InStr(iBlockO, sTempA, sLabelOpen, vbTextCompare)
    iLabelC = InStr(iLabelO + 1, sTempA, sLabelClose, vbTextCompare)
        'Stop procesing this page if no match on expected strings
        If iLabelO = 0 Or iLabelC = 0 Then GoTo gLabelResultsBad
        
gLabelResultsGood:
    'Make sure that we have a minimum of 1 character to work with:
    If iLabelC <= iLabelO Then GoTo gEndOfTheLine
    
        'Extract the Label
        sLabelTemp = Mid(sTempA, iLabelO, iLabelC - iLabelO)
        
        'Pre-Clean the Label
        sLabelTemp = Replace(sLabelTemp, sLabelOpen, "", , , vbTextCompare)
        sLabelTemp = Replace(sLabelTemp, sQuote, "", , , vbTextCompare)
        sLabelTemp = Replace(sLabelTemp, sReplaceExtra1, "", , , vbTextCompare)
        sLabelTemp = Trim(sLabelTemp)
        
        'Move to the next step:
        GoTo gExtractValue
        
gLabelResultsBad:
    'Stop processing this page if no match
    GoTo gEndOfTheLine
    
'LABEL: @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'Value: @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

gExtractValue:
    iValueO = InStr(iLabelC, sTempA, sValueOpen, vbTextCompare)
    iValueC = InStr(iValueO + 1, sTempA, sValueClose, vbTextCompare)
        'Stop processing this page if no match on expected strings
        If iValueO = 0 Or iValueC = 0 Then GoTo gValueResultsBad
        
gValueResultsGood:
    'Make sure that we have a minimum of 1 character to work with:
    If iValueC <= iValueO Then GoTo gEndOfTheLine
    
        'Extract the Value
        sValueTemp = Mid(sTempA, iValueO, iValueC - iValueO)
        
        'Pre-Clean the Label
        sValueTemp = Replace(sValueTemp, sValueOpen, "", , , vbTextCompare)
        sValueTemp = Replace(sValueTemp, sQuote, "", , , vbTextCompare)
        sValueTemp = Replace(sValueTemp, sReplaceExtra1, "", , , vbTextCompare)
        sValueTemp = Replace(sValueTemp, "<span>", "", , , vbTextCompare)
        sValueTemp = Replace(sValueTemp, "</span>", "", , , vbTextCompare)
        sValueTemp = Trim(sValueTemp)
        
        'Move to the next step:
        GoTo gLoadArray

gValueResultsBad:
    'Stop processing this page if no match
    GoTo gEndOfTheLine
    
'Value: @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    
'LoadArray: @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
gLoadArray:
'Check for the Corresponding header to know where the data should be dumped to:
    
gCheckForMatchingHeader:
    iTempG = 0
    
    'check to see if the Label matches a correct header value (consider instr?)
    For iLoop = LBound(aHeaders, 2) To UBound(aHeaders, 2)
        If UCase(sLabelTemp) = 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
        '*********************************************************************************************
        '*********************************************************************************************
        'Option 1: Dump the value (Standard Header)

        If aHeaders(1, iTempG) <> "&" Then aDump(1, iTempG) = sValueTemp
        
        'Option 2: Dump the value (Header Exception - Multiple Values [&]) (non-functioning)
        If aHeaders(1, iTempG) = "&" Then aDump(x, iTempG) = aDump(1, iTempG) & "|" & sValueTemp
        '*********************************************************************************************
        '*********************************************************************************************

    GoTo gIncrementStartSearchPosition
    
gIncrementStartSearchPosition:
    'Check for the next label
    iCharA = InStr(iValueC + 1, sTempA, sBlockOpen, vbTextCompare)
        'A: Stop the process - no more matches
            If iCharA = 0 Then GoTo gBonusRound
        'B: Check the remainder of the string - more matches available
            GoTo gRepeatDoUntilLoop
    

'LoadArray: @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
gBonusRound:
   
    iBonusO1 = InStr(1, sTempA, sBonusOpen1, vbTextCompare)
    iBonusC1 = InStr(iBonusO1 + 1, sTempA, sBonusClose1, vbTextCompare)
    
    If iBonusC1 <= iBonusO1 Or iBonusO1 = 0 Or iBonusC1 = 0 Then GoTo gEndOfTheLine
    aDump(1, 3) = Mid(sTempA, iBonusO1, iBonusC1 - iBonusO1)
    GoTo gEndOfTheLine
Loop
gEndOfTheLine:
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$


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

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

GoTo gMemoryCleanup

gMemoryCleanup:
'close down oWebBrowser and reset status bar
    'Set oWebBrowser = Nothing
    Application.StatusBar = ""

'Release Array memory
    Erase aHeaders: Erase aDump

'MsgBox "Done"
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