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
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
