合并多个html到工作簿

xing_chen

老师！有多个网上下载的html资料，现需将多个html文件批量复制到工作簿中，1个专题1个表。敬请老师赐教。谢谢！

xing_chen

有老师帮忙看看吗！这合并和excel的合并一样吗?谢谢了！

简七

1. Option Explicit
   
2. 
   
3. Private Function GetFileText(filePath As String, Optional charSet = "utf-8")
   
4. 
   
5.     Dim stream As Object
   
6.    
   
7.     Set stream = CreateObject("adodb.stream")
   
8.    
   
9.     With stream
   
10. 
    
11.         .charSet = charSet
    
12. 
    
13.         .Type = 2
    
14. 
    
15.         .Open
    
16. 
    
17.         .LoadFromFile filePath
    
18. 
    
19.         GetFileText = .readText
    
20.         
    
21.     End With
    
22. 
    
23.     Set stream = Nothing
    
24.    
    
25. End Function
    
26. 
    
27. 
    
28. Sub GetHTML()
    
29. 
    
30.     Dim folderPath$, filePath$
    
31.    
    
32.     folderPath = GetFolderPath
    
33.    
    
34.     If folderPath = "" Then Exit Sub
    
35.    
    
36.     filePath = Dir(folderPath & "\*.htm*")
    
37.    
    
38.     Dim dom As Object
    
39.    
    
40.     Dim title$, body
    
41.    
    
42.     While filePath <> ""
    
43.    
    
44.         Set dom = CreateObject("htmlfile")
    
45.         
    
46.         dom.write GetFileText(folderPath & "" & filePath)
    
47.         
    
48.         title = dom.getElementsByTagName("span").Item(0).ChildNodes(1).innerText
    
49.         
    
50.         body = "<table>" & dom.getElementsByTagName("div").Item(2).innerHTML & "</table>"
    
51.         
    
52.         dom.parentWindow.clipboardData.setData "text", body
    
53.         
    
54.         Set dom = Nothing
    
55.         
    
56.         With Worksheets.Add
    
57.             .Name = title
    
58.             .Activate
    
59.             .PasteSpecial Format:="Unicode 文本", Link:=False, DisplayAsIcon:=False
    
60.         End With
    
61.         
    
62.         filePath = Dir()
    
63.         
    
64.     Wend
    
65. 
    
66. End Sub
    
67. 
    
68. 
    
69. Private Function GetFolderPath()
    
70.     Dim FileDialog
    
71.    
    
72.     Set FileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
73.    
    
74.     FileDialog.title = "请选择数据文件夹"
    
75.    
    
76.     FileDialog.Show
    
77.    
    
78.     If FileDialog.SelectedItems.Count = 0 Then
    
79.    
    
80.         Set FileDialog = Nothing
    
81.         
    
82.         GetFolderPath = ""
    
83.         
    
84.         Exit Function
    
85.     End If
    
86.    
    
87.     GetFolderPath = FileDialog.SelectedItems(1)
    
88.    
    
89.     Set FileDialog = Nothing
    
90. End Function
    

复制代码

smsn

copy “d:\html文件夹路径\*.html” “d:\文件夹路径\all.htm”
开始运行下

smsn

使用英文引号

xing_chen

smsn 发表于 2023-3-2 18:45
使用英文引号

谢谢老师！运行的太棒了！又快又顺！抱歉！因为下午出去了！没有及时回复！另外，我没有用此句，copy “d:\html文件夹路径\*.html” “d:\文件夹路径\all.htm”。运行的也非常好呀！那此句还有用吗?