VBA - CopyTab Chrome Extension Helper

In preparation for these posts, I surf the internet a lot. I read many pages but it is a pain to write the HTML markup for every link I visit. I've decided to solve this pain by using a Chrome Extension called TabCopy in addition to some VBA code that will take TabCopy's output and style it into HTML.

So you need TabCopy Chrome Extension installed. Once installed , click on the icon and select a menu option to either (1) copy tab, (2) copy all tabs for that Chrome window or (3) copy all tabs for every Chrome window. Ensure the Expanded tab is highlighted on the bottom row as this affects what is copied to clipboard. You can select any of those menu options. If you paste into Notepad or a worksheet you should get something like the following

GitHub - dkackman/SqlLinq: Dynamic SQL queries of .NET IEnumerables
https://github.com/dkackman/SqlLinq

SqlLinq: Taking LINQ to SQL in the Other Direction - CodeProject
https://www.codeproject.com/Articles/28163/SqlLinq-Taking-LINQ-to-SQL-in-the-Other-Direction

Dynamically evaluated SQL LINQ queries - CodeProject
https://www.codeproject.com/Articles/43678/Dynamically-evaluated-SQL-LINQ-queries

TabCopy - Chrome Web Store
https://chrome.google.com/webstore/detail/tabcopy/micdllihgoppmejpecmkilggmaagfdmb

And the above looks eminently parsable. What I want to get to is the following HTML source so that I can paste into my blog post source ...

<li><a href="https://github.com/dkackman/SqlLinq">GitHub - dkackman/SqlLinq: Dynamic SQL queries of .NET IEnumerables</a></li>
<li><a href="https://www.codeproject.com/Articles/28163/SqlLinq-Taking-LINQ-to-SQL-in-the-Other-Direction">SqlLinq: Taking LINQ to SQL in the Other Direction - CodeProject</a></li>
<li><a href="https://www.codeproject.com/Articles/43678/Dynamically-evaluated-SQL-LINQ-queries">Dynamically evaluated SQL LINQ queries - CodeProject</a></li>
<li><a href="https://chrome.google.com/webstore/detail/tabcopy/micdllihgoppmejpecmkilggmaagfdmb">TabCopy - Chrome Web Store</a></li>

So the following code is to be pasted into the code behind a worksheet. It's quite defensive, it looks for the blanks between entries, it also ensure the lower text row is a valid url only if all entries are valid does it proceed to generate HTML ...

Option Explicit

Private mbProcessingChange As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not mbProcessingChange Then
        mbProcessingChange = True
        If Target.Columns.Count = 1 Then
            
            If (Target.Rows.Count + 1)  3 = (Target.Rows.Count + 1) / 3 Then
                Dim bInterspacedByBlanks As Boolean
                bInterspacedByBlanks = True
                
                Dim lRowLoop As Long
                For lRowLoop = 3 To Target.Rows.Count Step 3
                    If Len(Target.Cells(lRowLoop, 1)) > 0 Then
                        bInterspacedByBlanks = False
                        Exit For
                    End If
                Next
                
                If bInterspacedByBlanks Then
                    Dim bValidURLs As Boolean
                    bValidURLs = True
                    For lRowLoop = 2 To Target.Rows.Count Step 3
                        If Not IsValidURL(Target.Cells(lRowLoop, 1)) Then
                            bValidURLs = False
                            Exit For
                        End If
                    Next
            
                    If bValidURLs Then
                    
                        Dim dic As Object 'scripting.Dictionary
                        Set dic = VBA.CreateObject("scripting.Dictionary")
            
                        For lRowLoop = 1 To Target.Rows.Count Step 3
                            Dim sText As String
                            sText = Target.Cells(lRowLoop, 1)
                            
                            Dim sURL As String
                            sURL = Target.Cells(lRowLoop + 1, 1)
                            
                            
                            dic.Add dic.Count, "<li><a title="""" href=""" & sURL & """>" & sText & "</a></li>"
                        
                        Next
                        
                        Dim vItems As Variant
                        vItems = dic.Items
                        
                        ReDim vPaste(1 To dic.Count, 1 To 1) As Variant
                        Dim l As Long
                        For l = 1 To dic.Count
                            vPaste(l, 1) = vItems(l - 1)
                        Next l
                        
                        Target.Offset(0, 4).Resize(dic.Count).Value2 = vPaste

                    End If
            
                End If
            
            End If
        End If
        mbProcessingChange = False
    End If

End Sub

Public Function IsValidURL(ByRef sURL As String) As Boolean

    IsValidURL = False
    Dim sPattern As String
    sPattern = "^" 'Beginning of string
    sPattern = sPattern & "https?://" 'Protocol is http or https
    sPattern = sPattern & "[wd][wd-]*(.[wd-]+)*" 'Domain/Subdomain
    sPattern = sPattern & ".[w]+" 'gTLD
    sPattern = sPattern & "/" 'we need to not be in the webroot
    sPattern = sPattern & ".+" 'Check that we have stuff that comes after the slash

    IsValidURL = IsRegexMatch(sURL, sPattern)

End Function

Private Function IsRegexMatch(ByRef sText As String, ByVal sPattern As String) As Boolean
    IsRegexMatch = False

    Dim regex As Object
    Set regex = CreateObject("vbscript.regexp")

    regex.IgnoreCase = True
    regex.Global = True
    regex.Pattern = sPattern
    Dim Matches As Object
    Set Matches = regex.Execute(sText)
    If Matches.Count = 1 Then IsRegexMatch = True

End Function