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