Excelでサイトマップ作成ソフトを作ってみよう

'作成開始ボタンをクリック
Private Sub CommandButton1_Click()
    Dim lcoun As Long
    Dim lCol As Long
    Dim lNowRow As Long
    Dim lKei As Long
    
    
    If TextBox1 = "" Then
        MsgBox "作成するサイトアドレスを入力してください。"
        TextBox1.Activate
        Exit Sub
    End If
    
    'マウスポインターを砂時計に
    Application.Cursor = xlWait
    If ExCreateIEobject Then
        Range("A8:C65536").ClearContents
        
        lKei = 0
        lCol = 2
        lNowRow = 8
        Cells(lNowRow, lCol) = LCase(TextBox1)
        Cells(lNowRow, lCol + 1) = tIEobj.document.Title
        
        Range("C5") = TextBox1
        lcoun = ExGetLink(LCase(TextBox1), LCase(TextBox1), lNowRow, lCol)
        lKei = lKei + lcoun
        Range("C6") = lKei
        If lcoun > 0 Then
            Cells(lNowRow, lCol - 1) = "済"
            
            lNowRow = lNowRow + 1
            While Cells(lNowRow, 2) <> "" And lNowRow < 15
                If ExNavigateIEobject(Cells(lNowRow, lCol)) Then
                    Cells(lNowRow, lCol + 1) = tIEobj.document.Title
                    Range("C5") = Cells(lNowRow, lCol)
                    lcoun = ExGetLink(LCase(TextBox1), Cells(lNowRow, lCol), lMaxRow, lCol)
                    lKei = lKei + lcoun
                    Range("C6") = lKei
                    Cells(lNowRow, lCol - 1) = "済"
                End If
                lNowRow = lNowRow + 1
            Wend
            
            '済マークがないURLを再調査
            lNowRow = 9
            While Cells(lNowRow, 2) <> ""
                If Cells(lNowRow, lCol - 1) = "" Then
                    If ExNavigateIEobject(Cells(lNowRow, lCol)) Then
                        Cells(lNowRow, lCol + 1) = tIEobj.document.Title
                        Range("C5") = Cells(lNowRow, lCol)
                        lcoun = ExGetLink(LCase(TextBox1), Cells(lNowRow, lCol), lMaxRow, lCol)
                        lKei = lKei + lcoun
                        Range("C6") = lKei
                        Cells(lNowRow, lCol - 1) = "済"
                    End If
                End If
                lNowRow = lNowRow + 1
            Wend
        End If
    End If
    tIEobj.Quit
    Set tIEobj = Nothing
    
    If lKei > 0 Then
        'シートのソート
        ActiveSheet.Range(Cells(8, 1), Cells(lNowRow - 1, 3)).Sort _
         Key1:=Range("B8"), Order1:=xlAscending _
        , Key2:=Range("C8"), Order2:=xlAscending _
        , Header:=xlNo _
        , MatchCase:=False _
        , Orientation:=xlTopToBottom _
        , SortMethod:=xlPinYin
    End If
End Sub