vba 在网页中抓取指定内容

最新推荐文章于 2025-05-09 15:03:45 发布

Hann Yang

最新推荐文章于 2025-05-09 15:03:45 发布

阅读量6.8k

点赞数 5

CC 4.0 BY-SA版权

分类专栏：综合专栏

本文链接：https://blog.csdn.net/boysoft2002/article/details/113772948

综合专栏专栏收录该内容

45 篇文章

订阅专栏

介绍了一个使用VBA编写的程序，该程序可以从autopiano.cn网站抓取音乐曲谱及歌词，并将其保存到Excel中。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

用vba程序从网页里抓取想要的内容，如下代码可抓取autopiano.cn网站上的所有曲谱和歌词：

Private Sub MacraGrabTunes()
Dim iBegin, iEnd, iRow As Integer
Dim t0, t1 As Single
Dim Sign1, Sign2 As String
Dim strHtml, strTitle, strTune As String
Dim Web1 As Object
Set Web1 = CreateObject("Msxml2.ServerXMLHTTP.3.0")
Application.ScreenUpdating = False
t0 = Timer
For i = 1 To 5000
    strURL = "https://www.autopiano.cn/post/" & i
    Web1.Open "GET", strURL, False
    On Error Resume Next
    Web1.Send
    strHtml = Web1.responseText
    If Err < 0 Then
        strHtml = "检测网址找不到或没返回信息!"
        MsgBox strHtml
    Else
        Sign1 = "<div class=""section-content"">"
        iBegin = InStr(strHtml, Sign1)
        If iBegin < 1 Then
            strHtml = "没找到歌谱"
        Else
            Sign1 = "<title>"
            Sign2 = "- 自由钢琴"
            iBegin = InStr(strHtml, Sign1)
            iEnd = InStr(strHtml, Sign2)
            strTitle = Mid(strHtml, iBegin + Len(Sign1), iEnd - iBegin - Len(Sign1) - 1)
            
            Sign1 = "<div class=""section-content"">"
            iBegin = InStr(strHtml, Sign1)
            strHtml = Mid(strHtml, iBegin - 1, Len(strHtml))
            
            Sign2 = "</div>"
            iBegin = InStr(strHtml, Sign1)
            iEnd = InStr(strHtml, Sign2)
            strTune = Mid(strHtml, iBegin + Len(Sign1) + 1, iEnd - iBegin - Len(Sign1) - 1)
            
            Sign1 = "<div class=""section lyric-section"">"
            iBegin = InStr(strHtml, Sign1)
            If iBegin > 0 Then
                strHtml = Mid(strHtml, iBegin - 1, Len(strHtml))
            
                Sign1 = "<div class=""section-content"">"
                iBegin = InStr(strHtml, Sign1)
                iEnd = InStr(strHtml, Sign2)
                strHtml = Mid(strHtml, iBegin + Len(Sign1) + 1, iEnd - iBegin - Len(Sign1) - 1)
            Else
                strHtml = "-NULL-"
            End If
            If Len(strHtml) < 4 Then strHtml = "-NULL-"
            
            iRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            If iRow < 5 Then iRow = 5
            
            Cells(iRow, 1) = i
            Cells(iRow, 2) = strTitle
            Cells(iRow, 3) = strTune
            Cells(iRow, 4) = strHtml
            
            t1 = Timer
            Do
                DoEvents
            Loop While Timer - t1 < 0.02
        End If
    End If
Next

Cells.Replace What:="<p>=", Replacement:="'=", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="<p>", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="</p>", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Cells.Replace What:="<br />", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Application.ScreenUpdating = True
t1 = Timer
MsgBox "结束，用时:" & t1 - t0

End Sub

点此下载已抓取曲谱和歌词，.xlsm文件包含源代码。