Excel教程|Word教程|VBA应用-ExcelOffice

如何用vba遍历网页中的超链接，并输出超链接的目标属性href？

2018年8月20日作者：exceloffice

暂无评论

在编写网抓的解决方案时，会遇到需要提取网页的超链接元素<a>的href属性值的情况。

这时候一般使用getElementsByTagName方法获取网页的超链接元素<a>的集合对象，然后通过遍历集合获取具体的href属性值.

这时候可以使用如下的代码：

Sub QQ1722187970()
    Excel.Application.ScreenUpdating = False
    Excel.Application.Calculation = xlCalculationManual
    Dim sVerb As String
    Dim sUrl As String
    Dim sCharset As String
    Dim sPostData As String
    sVerb = "GET"
    sUrl = "http://www.mca.gov.cn/article/sj/xzqh//1980/?"
    sResult = HtmlBasic("GET", sUrl)
    Debug.Print rResult
    Call HtmlTable(sResult)
    Excel.Application.Calculation = xlCalculationAutomatic
    Excel.Application.ScreenUpdating = True
End Sub
Function HtmlBasic(ByVal sVerb As String, ByVal sUrl As String, Optional ByVal sCharset As String = "utf-8", Optional ByVal sPostData As String = "")
    'sVerb为发送的Html请求的方法,sUrl为具体的网址,sCharset为网址对应的字符集编码,sPostData为Post方法对应的发送body
    Dim oHtml As Object
    'https://msdn.microsoft.com/en-us/library/windows/desktop/aa384106(v=vs.85).aspx
    Set oHtml = VBA.CreateObject("WinHttp.WinHttpRequest.5.1")
    With oHtml
        Select Case sVerb
        Case "GET"
        .Open "GET", sUrl, False
        Case "POST"
        .Open "POST", sUrl, False
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        End Select
        .send (sPostData)
        '获取返回的字节数组
        bResult = .ResponseBody
        '按照指定的字符编码显示
        sResult = Byte2String(bResult, sCharset)
        Debug.Print sResult
        HtmlBasic = sResult
    End With
    Set oHtml = Nothing
End Function
Function Byte2String(bContent, ByVal sCharset As String)
    Const adTypeBinary = 1
    Const adTypeText = 2
    Const adModeRead = 1
    Const adModeWrite = 2
    Const adModeReadWrite = 3
    Dim oStream As Object
    '创建流对象
    Set oStream = CreateObject("ADODB.Stream")
    With oStream
        '打开流
        .Open
        '设置为字节模式
        .Type = adTypeBinary
        '写入字节
        .write bContent
        '将位置定位在第一个字节
        .Position = 0
        '设置为文本模式
        .Type = adTypeText
        '设置编码的字符集
        .Charset = sCharset
        '读取编码后的文本
         Byte2String = .ReadText
        '关闭流对象
        .Close
    End With
End Function
'提取网页表格的代码
Sub HtmlTable(ByVal sHtml As String)
    '网页html文档对象
    Dim oHtmlDom As Object
    '网页表格对象
    Dim oTable As Object
    '网页表格行对象
    Dim oRows As Object
    '网页表格单元格对象
    Dim oCells As Object
    '网页超链接元素对象
    Dim oA As Object
    '抓取的数据存放的excel表格对象
    Dim oWK As Worksheet
    Set oWK = Excel.ActiveSheet
    iRow = oWK.Range("a65536").End(xlUp).Row + 1
    Set oHtmlDom = CreateObject("htmlfile")
    With oHtmlDom
        .body.innerhtml = sHtml
        Set oTable = .getElementsByTagName("table")(0)
        Set oA = oTable.getElementsByTagName("a")
        '遍历第一个表格中的所有超链接
        For i = 0 To oA.Length - 1
            oWK.Cells(iRow, 1) = oA(i).href
            iRow = iRow + 1
        Next i
    End With
    oWK.Columns.AutoFit
    Set oHtmlDom = Nothing
    Set oTable = Nothing
    Set oRows = Nothing
    Set oCells = Nothing
End Sub

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

51

52

53

54

55

56

57

58

59

60

61

62

63

64

65

66

67

68

69

70

71

72

73

74

75

76

77

78

79

80

81

82

83

84

85

86

87

88

89

90

91

92

93

94

95

96

97

98

99

Sub QQ1722187970()

Excel.Application.ScreenUpdating = False

Excel.Application.Calculation = xlCalculationManual

Dim sVerb As String

Dim sUrl As String

Dim sCharset As String

Dim sPostData As String

sVerb = "GET"

sUrl = "http://www.mca.gov.cn/article/sj/xzqh//1980/?"

sResult = HtmlBasic("GET", sUrl)

Debug.Print rResult

Call HtmlTable(sResult)

Excel.Application.Calculation = xlCalculationAutomatic

Excel.Application.ScreenUpdating = True

End Sub

Function HtmlBasic(ByVal sVerb As String, ByVal sUrl As String, Optional ByVal sCharset As String = "utf-8", Optional ByVal sPostData As String = "")

'sVerb为发送的Html请求的方法,sUrl为具体的网址,sCharset为网址对应的字符集编码,sPostData为Post方法对应的发送body

Dim oHtml As Object

'https://msdn.microsoft.com/en-us/library/windows/desktop/aa384106(v=vs.85).aspx

Set oHtml = VBA.CreateObject("WinHttp.WinHttpRequest.5.1")

With oHtml

Select Case sVerb

Case "GET"

.Open "GET", sUrl, False

Case "POST"

.Open "POST", sUrl, False

.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"

End Select

.send (sPostData)

'获取返回的字节数组

bResult = .ResponseBody

'按照指定的字符编码显示

sResult = Byte2String(bResult, sCharset)

Debug.Print sResult

HtmlBasic = sResult

End With

Set oHtml = Nothing

End Function

Function Byte2String(bContent, ByVal sCharset As String)

Const adTypeBinary = 1

Const adTypeText = 2

Const adModeRead = 1

Const adModeWrite = 2

Const adModeReadWrite = 3

Dim oStream As Object

'创建流对象

Set oStream = CreateObject("ADODB.Stream")

With oStream

'打开流

.Open

'设置为字节模式

.Type = adTypeBinary

'写入字节

.write bContent

'将位置定位在第一个字节

.Position = 0

'设置为文本模式

.Type = adTypeText

'设置编码的字符集

.Charset = sCharset

'读取编码后的文本

Byte2String = .ReadText

'关闭流对象

.Close

End With

End Function

'提取网页表格的代码

Sub HtmlTable(ByVal sHtml As String)

'网页html文档对象

Dim oHtmlDom As Object

'网页表格对象

Dim oTable As Object

'网页表格行对象

Dim oRows As Object

'网页表格单元格对象

Dim oCells As Object

'网页超链接元素对象

Dim oA As Object

'抓取的数据存放的excel表格对象

Dim oWK As Worksheet

Set oWK = Excel.ActiveSheet

iRow = oWK.Range("a65536").End(xlUp).Row + 1

Set oHtmlDom = CreateObject("htmlfile")

With oHtmlDom

.body.innerhtml = sHtml

Set oTable = .getElementsByTagName("table")(0)

Set oA = oTable.getElementsByTagName("a")

'遍历第一个表格中的所有超链接

For i = 0 To oA.Length - 1

oWK.Cells(iRow, 1) = oA(i).href

iRow = iRow + 1

Next i

End With

oWK.Columns.AutoFit

Set oHtmlDom = Nothing

Set oTable = Nothing

Set oRows = Nothing

Set oCells = Nothing

End Sub

如何用vba将网抓的网页源代码直接打开显示在文本文件中？

2018年8月20日作者：ExcelOffice

暂无评论

在编写vba网抓解决方案时，经常需要查看网页的源代码。

有些是直接输出到vbe的立即窗口，有些是用网抓软件查看。

这里介绍一种直接将指定网页的源代码直接打开显示在文本文件中的方法，代码如下：

Sub QQ1722187970()
    Dim oHtml As Object
    Set oHtml = VBA.CreateObject("WinHttp.WinHttpRequest.5.1")
    Dim sUrl As String
    '指定要抓取的网站
    sUrl = "http://www.mca.gov.cn/article/sj/xzqh/2018/201808/20180800010436.shtml"
    Dim sCharset As String
    '指定要抓取的网站的字符编码
    sCharset = "utf-8"
    With oHtml
        .Open "GET", sUrl, False
        .send
        '获取返回的字节数组
        bResult = .ResponseBody
        '按照指定的字符编码显示
        sResult = Byte2String(bResult, sCharset)
        Debug.Print sResult
    End With
    Set oHtml = Nothing
End Sub
Function Byte2String(bContent, ByVal sCharset As String)
    '添加容错语句，防止文本文件不存在时，Kill语句出错
    On Error Resume Next
    Const adTypeBinary = 1
    Const adTypeText = 2
    Const adModeRead = 1
    Const adModeWrite = 2
    Const adModeReadWrite = 3
    Dim oStream As Object
    '创建流对象
    Set oStream = CreateObject("ADODB.Stream")
    With oStream
        '打开流
        .Open
        '设置为字节模式
        .Type = adTypeBinary
        '写入字节
        .write bContent
        '将位置定位在第一个字节
        .Position = 0
        '设置为文本模式
        .Type = adTypeText
        '设置编码的字符集
        .Charset = sCharset
        '读取编码后的文本
        Byte2String = .ReadText
        sPath = Excel.ThisWorkbook.Path
        sFilePath = sPath & "\view-source.txt"
        Kill sFilePath
        '将源代码保存到文本文件中
        .SaveToFile sFilePath
        '打开文本文件
        Shell ("notepad " & sFilePath), vbMaximizedFocus
        '关闭流对象
        .Close
    End With
End Function

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

51

52

53

54

55

56

57

Sub QQ1722187970()

Dim oHtml As Object

Set oHtml = VBA.CreateObject("WinHttp.WinHttpRequest.5.1")

Dim sUrl As String

'指定要抓取的网站

sUrl = "http://www.mca.gov.cn/article/sj/xzqh/2018/201808/20180800010436.shtml"

Dim sCharset As String

'指定要抓取的网站的字符编码

sCharset = "utf-8"

With oHtml

.Open "GET", sUrl, False

.send

'获取返回的字节数组

bResult = .ResponseBody

'按照指定的字符编码显示

sResult = Byte2String(bResult, sCharset)

Debug.Print sResult

End With

Set oHtml = Nothing

End Sub

Function Byte2String(bContent, ByVal sCharset As String)

'添加容错语句，防止文本文件不存在时，Kill语句出错

On Error Resume Next

Const adTypeBinary = 1

Const adTypeText = 2

Const adModeRead = 1

Const adModeWrite = 2

Const adModeReadWrite = 3

Dim oStream As Object

'创建流对象

Set oStream = CreateObject("ADODB.Stream")

With oStream

'打开流

.Open

'设置为字节模式

.Type = adTypeBinary

'写入字节

.write bContent

'将位置定位在第一个字节

.Position = 0

'设置为文本模式

.Type = adTypeText

'设置编码的字符集

.Charset = sCharset

'读取编码后的文本

Byte2String = .ReadText

sPath = Excel.ThisWorkbook.Path

sFilePath = sPath & "\view-source.txt"

Kill sFilePath

'将源代码保存到文本文件中

.SaveToFile sFilePath

'打开文本文件

Shell ("notepad " & sFilePath), vbMaximizedFocus

'关闭流对象

.Close

End With

End Function

如何用vba提取单元格数据中的字母？

2018年8月17日作者：exceloffice

暂无评论

如图所示，如果要提取单元格中的字母，用普通的excel工作表函数是无法实现，可以用正则表达式。

以下是在vba中的自定义函数，无论字母位于单元格数据前中后，都可以提取单元格中的字母，不区分大小写。

'sOrignText参数表示要执行正则表达式的字符串,
Function GetAZaz(ByVal sOrignText As String)
    '定义正则表达式对象
    Dim oRegExp As Object
    '定义匹配字符串集合对象
    Dim oMatches As Object
    '定义匹配子字符串集合对象
    Dim oSubMatches As Object
    Dim oMatch As Object
    Dim str1 As String
    '创建正则表达式
    Set oRegExp = CreateObject("vbscript.regexp")
    With oRegExp
        '设置是否匹配所有的符合项，True表示匹配所有, False表示仅匹配第一个符合项
        .Global = True
        '设置是否区分大小写，True表示不区分大小写, False表示区分大小写
        .IgnoreCase = True
        '设置要查找的正则规则
        .Pattern = "[^a-z^A-Z]"
        '判断是否可以找到匹配的字符，若可以则返回True
        If .Test(sOrignText) Then
'            对字符串执行正则查找，返回所有的查找值的集合，若未找到，则为空
            Set oMatches = .Execute(sOrignText)
'            For Each oMatch In oMatches
'                '返回匹配到的字符串的位置
'                Debug.Print oMatch.FirstIndex
'                '返回匹配到的字符串的长度
'                Debug.Print oMatch.Length
'                '返回子匹配结果
'                str1 = oMatch.SubMatches(0)
'            Next
'            GetAZaz = oMatches(0).Value
'            把字符串中用正则找到的所有匹配字符替换为其它字符
            GetAZaz = .Replace(sOrignText, "")
        Else
            GetAZaz = sOrignText
        End If
    End With
    Set oRegExp = Nothing
    Set oMatches = Nothing
End Function

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

'sOrignText参数表示要执行正则表达式的字符串,

Function GetAZaz(ByVal sOrignText As String)

'定义正则表达式对象

Dim oRegExp As Object

'定义匹配字符串集合对象

Dim oMatches As Object

'定义匹配子字符串集合对象

Dim oSubMatches As Object

Dim oMatch As Object

Dim str1 As String

'创建正则表达式

Set oRegExp = CreateObject("vbscript.regexp")

With oRegExp

'设置是否匹配所有的符合项，True表示匹配所有, False表示仅匹配第一个符合项

.Global = True

'设置是否区分大小写，True表示不区分大小写, False表示区分大小写

.IgnoreCase = True

'设置要查找的正则规则

.Pattern = "[^a-z^A-Z]"

'判断是否可以找到匹配的字符，若可以则返回True

If .Test(sOrignText) Then

' 对字符串执行正则查找，返回所有的查找值的集合，若未找到，则为空

Set oMatches = .Execute(sOrignText)

' For Each oMatch In oMatches

' '返回匹配到的字符串的位置

' Debug.Print oMatch.FirstIndex

' '返回匹配到的字符串的长度

' Debug.Print oMatch.Length

' '返回子匹配结果

' str1 = oMatch.SubMatches(0)

' Next

' GetAZaz = oMatches(0).Value

' 把字符串中用正则找到的所有匹配字符替换为其它字符

GetAZaz = .Replace(sOrignText, "")

Else

GetAZaz = sOrignText

End If

End With

Set oRegExp = Nothing

Set oMatches = Nothing

End Function

如何用vba不保存关闭所有打开的word文档？

2018年8月16日作者：exceloffice

暂无评论

在用vba遍历文件夹中的word文档时，可以选择每个文档打开后关闭，也可以选择全部文档打开后再批量关闭。

要关闭word文档，需要用到Document.Close方法。

它的语法如下：

expression . Close( SaveChanges , OriginalFormat , RouteDocument )

1	expression . Close( SaveChanges , OriginalFormat , RouteDocument )

其中SaveChanges参数是指定是否需要保存对打开的文档的修改，可以是以下值：

名称
值
说明

wd[……]

阅读全文

如何用vba操作word文档的邮件合并？

2018年8月15日作者：exceloffice

暂无评论

word vba中MailMerge对象代表邮件合并。

一个word文档中有且仅有一个MailMerge对象。

所有与邮件合并相关的操作都可以通过操作MailMerge对象来实现。

以下是一个显示邮件合并连接字符串的代码：

Sub QQ1722187970()
    Dim oMailMerge As MailMerge
    Dim oDoc As Document
    Set oDoc = Word.ActiveDocument
    Set oMailMerge = oDoc.MailMerge
    Dim oMailMergeDataSource As MailMergeDataSource
    '邮件合并对象
    With oMailMerge
        '邮件合并的数据源
        Set oMailMergeDataSource = .DataSource
        With oMailMergeDataSource
            '输出连接字符串
            Debug.Print .ConnectString
        End With
    End With
End Sub

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

Sub QQ1722187970()

Dim oMailMerge As MailMerge

Dim oDoc As Document

Set oDoc = Word.ActiveDocument

Set oMailMerge = oDoc.MailMerge

Dim oMailMergeDataSource As MailMergeDataSource

'邮件合并对象

With oMailMerge

'邮件合并的数据源

Set oMailMergeDataSource = .DataSource

With oMailMergeDataSource

'输出连接字符串

Debug.Print .ConnectString

End With

End Sub

如何用vba调出调色板选择颜色对话框，并且保存使用选择的颜色？

2018年8月15日作者：exceloffice

暂无评论

在设计vba解决方案时，有时候需要给用户提供选择颜色的操作，同时，基于用户选择的颜色执行某些操作。

在vba中可以使用如下的代码弹出颜色对话框供选择颜色：

Sub QQ1722187970()
    Dim oDialog As Dialog
    Set oDialog = Excel.Application.Dialogs(xlDialogEditColor)
    'show方法后一定要输入一个数值参数,才能打开xlDialogEditColor对话框
    '该数值可以是1-56之间的任意整数
    oDialog.Show (1)
End Sub

1

2

3

4

5

6

7

Sub QQ1722187970()

Dim oDialog As Dialog

Set oDialog = Excel.Application.Dialogs(xlDialogEditColor)

'show方法后一定要输入一个数值参数,才能打开xlDialogEditColor对话框

'该数值可以是1-56之间的任意整数

oDialog.Show (1)

End Sub

当在上述“颜色”对话框中选择颜色后，单击“确定”按钮，直接关闭对话框。

如果要使用上述选中的颜色，需要调用Workbook.Colors属性。

Wo[……]

阅读全文

为什么用vba无法打开xlDialogEditColor对话框？

2018年8月15日作者：exceloffice

暂无评论

vba中提供了Application对象的Dialogs属性用于返回excel应用程序的内置对话框。

比如如下的代码将分别弹出“打开”文件对话框和”设置字体”对话框。

Sub QQ1722187970()
    '弹出打开文件对话框
    Excel.Application.Dialogs(xlDialogOpen).Show
    '弹出设置字体对话框
    Excel.Application.Dialogs(xlDialogFont).Show
End Sub

1

2

3

4

5

6

Sub QQ1722187970()

'弹出打开文件对话框

Excel.Application.Dialogs(xlDialogOpen).Show

'弹出设置字体对话框

Excel.Application.Dialogs(xlDialogFont).Show

End Sub

其它的内置对话框常量可以见内置对话框枚举。

在vba中提供了Application对象的Dialogs属性返回的是Dialog对象。

在vba中[……]

阅读全文

如何在vba中为OnAction属性指定宏名？

2018年8月14日作者：exceloffice

暂无评论

在excel VBA中按下F2快捷键，在弹出的“对象浏览器”对话框中输入OnAction，会发现只有4个对象具有OnAction属性，如下图所示：

在vba中我们可以为Shape、CommandBarControl、CommandBarComboBox、CommandBarButton对象添加OnAction属性。

OnAction属性的作用是指定单击以上对象时要执行的vba过[……]

阅读全文

如何用vba实现聚光灯高亮行列单元格的功能？

2018年8月14日作者：exceloffice

暂无评论

在wps中有个聚光灯功能，可以实现高亮选中的单元格所在的行和列。

在excel中虽然没有内置这个功能，但是可以通过vba代码实现类似的效果。

如下动画所示：

在Sheet1模块中插入如下的Worksheet_SelectionChange事件代码，即可实现简单的聚光灯功能：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count = 1 Then
        Dim oWK As Worksheet
        Dim oRng As Range
        Set oWK = Excel.ActiveSheet
        Set oRng = Target.CurrentRegion
        Dim oFC As FormatCondition
        iRow = Target.Row
        iCol = Target.Column
        sF = "=OR(ROW()=" & iRow & ",COLUMN()=" & iCol & ")"
        iCol = oRng.FormatConditions.Count
        '先删除原来的条件格式
        For Each oFC In oRng.FormatConditions
            oFC.Delete
        Next
        '添加以公式为判断依据的条件格式
        Set oFC = oRng.FormatConditions.Add(xlExpression, , sF)
        With oFC
            '设置条件格式的填充色
            .Interior.Color = vbYellow
        End With
    End If
End Sub

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Count = 1 Then

Dim oWK As Worksheet

Dim oRng As Range

Set oWK = Excel.ActiveSheet

Set oRng = Target.CurrentRegion

Dim oFC As FormatCondition

iRow = Target.Row

iCol = Target.Column

sF = "=OR(ROW()=" & iRow & ",COLUMN()=" & iCol & ")"

iCol = oRng.FormatConditions.Count

'先删除原来的条件格式

For Each oFC In oRng.FormatConditions

oFC.Delete

Set oFC = oRng.FormatConditions.Add(xlExpression, , sF)

With oFC

'设置条件格式的填充色

.Interior.Color = vbYellow

End With

End If

End Sub

以上代码的原理是用条件格式来[……]

阅读全文

如何用vba给单元格区域添加、修改、删除条件格式？

2018年8月14日作者：exceloffice

暂无评论

在vba中FormatCondition对象代表条件格式。

如果要给Range对象添加条件格式，可以用FormatConditions.Add方法，它的语法如下：

expression . Add( Type , Operator , Formula1 , Formula2 )

1	expression . Add( Type , Operator , Formula1 , Formula2 )

其中Type参数是要添加的条件格式的类型，可以是基于值添加的条件格式，也可以是用公式判断的条件格式。

Type参数将影响后面Operator , Form[……]

阅读全文

近期文章

关键字

功能