VBA三例（word、excel），有一个群众们喜闻乐见的爬虫

一

需求：隔行将指定目录中的图片插入表格中 (word)

'ThisDocument
Private Sub cmdClear_Click()
    Dim i As Integer
    With ThisDocument.Tables(1)
        For i = 1 To .Rows.Count
            If i Mod 2 = 1 Then
                .Cell(i, 1).Select
                Selection.Delete Unit:=wdCharacter, Count:=1
                .Cell(i, 2).Select
                Selection.Delete Unit:=wdCharacter, Count:=1
                .Cell(i, 3).Select
                Selection.Delete Unit:=wdCharacter, Count:=1
            End If
        Next i
    End With
    Selection.HomeKey Unit:=wdStory
    MsgBox "清除图片完成", vbOKOnly + vbInformation, "Tips:"
End Sub

Private Sub cmdWorkSpace_Click()
    frmImport.Show
End Sub

'frmImport
Dim strPat As String
Private Sub cmbBrowser_Click()
    Dim strSel As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择图片文件夹"
        If .Show = True Then strSel = .SelectedItems(1)
    End With
    'txtPath.Text
    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists(strSel) Then
            txtPath.Text = strSel
        Else
            MsgBox "文件夹不存在", vbCritical + vbOKOnly, "错误:"
        End If
    End With
End Sub

Private Sub cmdImport_Click()
    Dim intPicCount As Integer
    If Int(txtPicCount.Text) = txtPicCount.Text And Int(txtPicCount.Text) > 0 Then
        intPicCount = Int(txtPicCount.Text)
    Else
        MsgBox "填写错误，图片数量必须为整数", vbOKOnly + vbInformation, "Tips:"
        txtPicCount.Text = 500
        Exit Sub
    End If
    Dim i As Integer
    CheckVali
    With CreateObject("Scripting.FileSystemObject")
       If .FolderExists(Split(lblFile.Caption, txtGud.Text)(0)) = False Then
            cmdImport.Enabled = False
            Exit Sub
        End If
    End With
    On Error Resume Next
    For i = 1 To intPicCount
        InsertPic (i)
    Next i
    MsgBox "插入完毕", vbInformation + vbOKOnly, "Tips:"
    Selection.HomeKey Unit:=wdStory
    Unload Me
End Sub

Sub CheckVali()
    txtGud.Text = Trim(txtGud.Text)
    txtPath.Text = Trim(txtPath.Text)
    strPat = Replace(Trim(txtPath.Text) & "\", "\\", "\") & Trim(txtGud.Text)
    lblFile.Caption = Replace(txtPath.Text & "\", "\\", "\") & txtGud.Text & "***.jpg"
    With CreateObject("Scripting.FileSystemObject")
        If InStr(lblFile.Caption, txtGud.Text) = 0 Then
            cmdImport.Enabled = False
            Exit Sub
        End If
        If .FolderExists(Split(lblFile.Caption, txtGud.Text)(0)) = False Then
            cmdImport.Enabled = False
            Exit Sub
        Else
            cmdImport.Enabled = True
        End If
    End With
End Sub

Sub InsertPic(ByVal picIdx As Integer)
    ThisDocument.Tables(1).Cell(((picIdx - 1) \ 3) * 2 + 1, ((picIdx - 1) Mod 3) + 1).Select
    Selection.InlineShapes.AddPicture FileName:=strPat & Format(picIdx, "000") & ".jpg", LinkToFile:=False, SaveWithDocument:=True
End Sub
Private Sub UserForm_Initialize()
    CheckVali
End Sub

Private Sub txtGud_Change()
    CheckVali
End Sub

Private Sub txtPath_Change()
    CheckVali
End Sub

二

(来自CSDN我的回帖)

需求(excel、爬虫)：请大佬们帮忙爬取一下蛋卷基金的历史净值数据，谢谢

Sub yyy()
    Dim resp As String, count As Integer, result() As String, row As Integer
    Cells(1, 1) = "日期"
    Cells(1, 2) = "净值"
    Cells(1, 3) = "日涨幅"
    row = 1
     
    '通过接口获取数据（JSON格式）
    Set doc = CreateObject("HTMLFILE")
    Set client = CreateObject("Msxml2.ServerXMLHTTP")
    client.Open "GET", "https://danjuanapp.com/djapi/fund/nav/history/110022?size=10000", False
    client.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/63.0.3239.132 Safari/537.36"
    client.send
    resp = client.ResponseText
    Debug.Print resp
     
    Set Window = doc.parentWindow
    '用js对数据进行处理
    Window.execScript "var result=''; var res=" & resp & ";item_count=res.data.total_items; var items=res.data.items; for (var i = 0; i<items.length; i++){result = result + items[i].date + ',' + items[i].value + ',' + items[i].percentage +'\r\n';};"
     
    count = Window.item_count
    Debug.Print "共" & count & "条记录"
     
    result = Split(Window.result, vbCrLf)
    For Each rec In result
        col = Split(rec, ",")
        If UBound(col) > 1 Then
            row = row + 1
            Cells(row, 1) = col(0)
            Cells(row, 2) = col(1)
            Cells(row, 3) = IIf(col(2) = "undefined", "无", col(2))
        End If
    Next
 
End Sub

三

(来自CSDN我的回帖)

需求(excel)：

Sub x()
For i = 1 To Sheet1.UsedRange.Rows.Count
    If Cells(i, 1) = "" Then Exit For
    Dim datenow, yearnow, col, monnow, qtr
    col = 2
    datenow = CDate(Cells(i, 1))
    yearnow = Year(datenow)
    For j = 2011 To yearnow - 1
        Cells(i, col) = CDate(j & "/12/31")
        col = col + 1
    Next j

    monnow = Month(datenow)
    qtr = IIf(monnow Mod 3 = 0, monnow, 3 * (monnow \ 3 + 1))

    For j = 3 To qtr Step 3
        Cells(i, col) = DateAdd("d", -1, DateAdd("M", 1, CDate(yearnow & "/" & j & "/1")))
        col = col + 1
    Next j
Next
End Sub