GetContent

Sub GetContent(ByVal URL As String, ByVal SheetName As String)
    Dim strText As String
    Dim i As Long
    Dim OneSpan
    Dim IsContent As Boolean

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .Send
        strText = .responsetext
    End With

    Dim arr() As String
    ReDim arr(1 To 1) As String

    With CreateObject("htmlfile")
        .write strText
        i = 0
        For Each OneSpan In .getElementsByTagName("span")
            s = RegReplace(OneSpan.innerhtml, "<.*?>")
            s = Replace(s, " ", "")

            If s = " 排行榜" Then IsContent = False
            If IsContent Then
                i = i + 1
                ReDim Preserve arr(1 To i)
                arr(i) = s
                'Debug.Print s
                'If i = 100 Then Exit For
            End If
            If s = "分类：" Then IsContent = True

        Next
    End With

    Dim brr() As String
    ReDim brr(1 To 1)

    brr(1) = arr(1)
    M = 1
    For n = 2 To i
        If RegTest(arr(n - 1), "[A-D].") Or RegTest(arr(n - 1), "^\d*?．??$") Then
            brr(M) = brr(M) & arr(n)
        Else
            M = M + 1
            ReDim Preserve brr(1 To M)
            brr(M) = arr(n)
        End If
    Next n

    For i = 1 To M
        'Debug.Print brr(i)
        If i = 150 Then Exit For
    Next i

    Set sht = AddWorksheet(ThisWorkbook, SheetName)

    With sht
        .Cells.ClearContents
        .Range("A1:A1").Value = Array("内容")
        .Range("A2").Resize(M, 1).Value = _
        Application.WorksheetFunction.Transpose(brr)
    End With

End Sub

Sub TestRegReplace()
    s = "215MY"
    s = RegReplace(s, "[A-Z]")
    Debug.Print s
End Sub
Public Function RegReplace(ByVal OrgText As String, ByVal Pattern As String, Optional RepStr As String = "") As String
'传递参数 ：原字符串， 匹配模式 ，替换字符
    Dim Regex As Object
    Dim newText As String
    Set Regex = CreateObject("VBScript.RegExp")
    With Regex
        .Global = True
        .Pattern = Pattern
    End With
    newText = Regex.Replace(OrgText, RepStr)
    RegReplace = newText
    Set Regex = Nothing
End Function

Public Function RegTest(ByVal OrgText As String, ByVal Pattern As String) As Boolean
'传递参数 ：原字符串， 匹配模式
    Dim Regex As Object
    Set Regex = CreateObject("VBScript.RegExp")
    With Regex
        .Global = True
        .Pattern = Pattern
    End With
    RegTest = Regex.TEST(OrgText)
    Set Regex = Nothing
End Function

Sub dd()
    Debug.Print RegTest("13.", "^\d+?.$")
End Sub

Function AddWorksheet(ByVal Wb As Workbook, ByVal ShtName As String, Optional ReplaceSymbol As Boolean = True) As Worksheet
    Dim sht As Worksheet
    If Len(ShtName) = 0 Or Len(ShtName) > 31 Then
        Set AddWorksheet = Nothing
        MsgBox "Worksheet名称长度不符！", vbInformation, "AddWorksheet"
        Exit Function
    Else
        On Error Resume Next
        Set sht = Wb.Worksheets(ShtName)
        If Err.Number = 9 Then
            Set sht = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
            Err.Clear
            On Error GoTo 0
            On Error Resume Next
            sht.Name = ShtName
            If Err.Number = 1004 Then
                Err.Clear
                On Error GoTo 0
                If ReplaceSymbol Then
                    arr = Array("/", "\", "?", "*", "[", "]")
                    For i = LBound(arr) To UBound(arr)
                        ShtName = Replace(ShtName, arr(i), "")
                    Next i
                    Set AddWorksheet = AddWorksheet(Wb, ShtName)    '再次调用
                Else
                    Set AddWorksheet = Nothing
                    MsgBox "Worksheet名称含有特殊符号！", vbInformation, "AddWorksheet"
                End If
            Else
                Set AddWorksheet = sht
            End If
        ElseIf Err.Number = 0 Then
            Set AddWorksheet = sht
        End If
    End If
End Function