ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 248|回复: 9

[求助] 紧急求助多个格式相同本地html文件上的指定数据提取到Excel中

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-10-17 22:43 | 显示全部楼层 |阅读模式
有多个html文件,格式都差不多,想把其中的一项或几项数据一键提取出来,希望大侠帮忙。看了论坛上相似的搞了半天没搞出来。谢谢大家了

模板.rar

75.16 KB, 下载次数: 12

TA的精华主题

TA的得分主题

发表于 2020-10-18 08:13 | 显示全部楼层
QQ截图20201018081258.jpg 之前写的,参考下吧。。。

评分

参与人数 3鲜花 +7 收起 理由
Datous + 2
毅阳 + 2 感谢帮助
zpy2 + 3 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-10-18 08:36 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-10-18 09:13 | 显示全部楼层
毅阳 发表于 2020-10-18 08:36
谢谢 非常感谢,有没有文本格式的文件啊

自己敲一遍也不复杂,

如果好用,别忘记送花给帮助过你的朋友。

评分

参与人数 1鲜花 +2 收起 理由
毅阳 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-10-18 10:26 | 显示全部楼层
毅阳 发表于 2020-10-18 08:36
谢谢 非常感谢,有没有文本格式的文件啊

Sub 汇总(
Application. ScreenUpdating= False
Application.DisplayAlerts = False
Dim MyPath,MyName,AWbName,Wb As Workbook,n,m
Dim arr,brr(1 To 5000,1To 8)
MyPathActiveWorkbook. Path
MyName = Dir(MyPath&"” &"*.html")
AWbName = ActiveWorkbook.Name
Do While MyName”
If MyName> AWbName Then
Set Wb = Workbooks.Open (MyPath&"" & MyName)
arr = ActiveSheet.UsedRange
Wb.Close False
For i= 2To UBound(arr)
n= n +1
If InStr(arr(i,2),"—"0 Then m = arr(i,1)
If Len(m)= 2 Then m ="0o"&m
If Len(m)= 3 Then m ="0"& m
brr(n,1) = m
brr(n,2)= arr(2,2)
brr(n,3= arr(i,1)
brr(n,4)= arr(i,2)
brr(n, 5) = arr(i,3)
brr(n,6)= arr(i, 4)
brr(n,7)= arr(i,5)
brr(n,8)= arr(i,6)
Next
End If
MyName = Dir
Loop
Rows("2:65536").Delete
[a2].Resize(UBound(brr,8).= brr
ryoEI HOME.NET
MsgBox"提取完毕!",,"报告!"”
Application.ScreenUpdating = True
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-10-18 10:38 | 显示全部楼层
  1. Sub wytq()
  2. Application.ScreenUpdating = False
  3. Application.DisplayAlerts = False
  4. Dim MyPath, MyName, AWbName, Wb As Workbook, n, m
  5. Dim arr, brr(1 To 5000, 1 To 8)
  6. MyPath = ActiveWorkbook.Path
  7. MyPath = Dir(MyPath & "" & "*.html")
  8. AWbName = ActiveWorkbook.Name
  9. Do While MyName <> ""
  10. If MyName <> AWbName Then
  11. Set Wb = Workbooks.Open(MyPath & "" & MyName)
  12. arr = ActiveSheet.UsedRange
  13. Wb.Close False
  14. For i = 2 To UBound(arr)
  15. n = n + 1
  16. If InStr(arr(i, 2), "--") > 0 Then m = arr(i, 1)
  17. If Len(m) = 2 Then m = "00" & m
  18. If Len(m) = 3 Then m = "0" & m
  19. brr(n, 1) = m
  20. brr(n, 2) = arr(2, 2)
  21. brr(n, 3) = arr(i, 1)
  22. brr(n, 4) = arr(i, 2)
  23. brr(n, 5) = arr(i, 3)
  24. brr(n, 6) = arr(i, 4)
  25. brr(n, 7) = arr(i, 5)
  26. brr(n, 8) = arr(i, 6)
  27. Next
  28. End If
  29. MyName = Dir
  30. Loop
  31. Rows("2:65536").Delete
  32. [a2].Resize(UBound(brr), 8) = brr
  33. MsgBox "提取完毕!", , "报告!"
  34. Application.ScreenUpdating = True
  35. End Sub
复制代码

各位大神帮忙看看呢,还是不能调取网页数据 ,是不是我代码打错了?能解释一下代码吗?谢谢!学习中。

这是需要提取到的excel

这是需要提取到的excel

这是网页文件

这是网页文件

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-10-18 10:40 | 显示全部楼层
约定的童话 发表于 2020-10-18 08:13
之前写的,参考下吧。。。

Sub wytq()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim MyPath, MyName, AWbName, Wb As Workbook, n, m
Dim arr, brr(1 To 5000, 1 To 8)
MyPath = ActiveWorkbook.Path
MyPath = Dir(MyPath & "\" & "*.html")
AWbName = ActiveWorkbook.Name
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
arr = ActiveSheet.UsedRange
Wb.Close False
For i = 2 To UBound(arr)
n = n + 1
If InStr(arr(i, 2), "--") > 0 Then m = arr(i, 1)
If Len(m) = 2 Then m = "00" & m
If Len(m) = 3 Then m = "0" & m
brr(n, 1) = m
brr(n, 2) = arr(2, 2)
brr(n, 3) = arr(i, 1)
brr(n, 4) = arr(i, 2)
brr(n, 5) = arr(i, 3)
brr(n, 6) = arr(i, 4)
brr(n, 7) = arr(i, 5)
brr(n, 8) = arr(i, 6)
Next
End If
MyName = Dir
Loop
Rows("2:65536").Delete
[a2].Resize(UBound(brr), 8) = brr
MsgBox "提取完毕!", , "报告!"
Application.ScreenUpdating = True
End Sub
帮看看还是不能提取,是我代码输入有错误吗?

TA的精华主题

TA的得分主题

发表于 2020-10-18 12:34 | 显示全部楼层
毅阳 发表于 2020-10-18 10:40
Sub wytq()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

代码要做部分修改适配你的文件,框架是对的

评分

参与人数 1鲜花 +2 收起 理由
毅阳 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-10-18 19:26 | 显示全部楼层
约定的童话 发表于 2020-10-18 12:34
代码要做部分修改适配你的文件,框架是对的

能帮忙解释一下代码吗 不懂

TA的精华主题

TA的得分主题

发表于 2020-10-19 09:29 | 显示全部楼层
毅阳 发表于 2020-10-18 19:26
能帮忙解释一下代码吗 不懂

Sub wytq()
    Application.ScreenUpdating = False
    Dim F, Wb As Workbook, n
    Dim arr, brr(1 To 5000, 1 To 8)
    F = Dir(ActiveWorkbook.Path & "\html\" & "*.html")
    Do While F <> ""
        Set Wb = Workbooks.Open(ActiveWorkbook.Path & "\html\" & F)
        arr = ActiveSheet.UsedRange
        Wb.Close False
        n = n + 1
        brr(n, 1) = F '文件名
        brr(n, 2) = arr(9, 2) '程序名称
        brr(n, 3) = arr(15, 2) '机床加工时间
        F = Dir
    Loop
    Rows("2:65536").Delete
    [a2].Resize(UBound(brr), 8) = brr
    MsgBox "提取完毕!", , "报告!"
End Sub
只提取了前三列,后面数学英语那些没找到对应项目
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-10-30 21:13 , Processed in 0.081713 second(s), 19 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表