设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 请教：用excel一键提取文本文档里的所需数据
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 3367|回复: 9

[已解决]请教：用excel一键提取文本文档里的所需数据

[复制链接]
发表于 2014-9-17 15:30 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
文本数据内容如下：

Windows XP 安全更新程序 (KB979309)
典型下载大小: 251 KB , 少于 1 分钟
现已确认有一个安全问题，未通过身份验证的远程攻击者可能会利用此问题危及系统的安全并获取对该系统的控制权。您可以通过安装本 Microsoft 更新程序来保护系统不受侵害。安装本更新程序后，可能必须重新启动系统。  详细信息...
不再显示此更新程序



excel中显示效果如下：

版本                             名称                                                       文件大小        说明
KB979309             Windows XP 安全更新程序 (KB979309)             251 KB        现已确认有一个安全问题，未通过身份验证的远程攻击者可能会利用此问题危及系统的安全并获取对该系统的控制权。您可以通过安装本 Microsoft 更新程序来保护系统不受侵害。安装本更新程序后，可能必须重新启动系统。


由于数据较多，查找复制粘贴会让人崩溃的，请教下大侠如何用VBA来实现一键导入。
附件如下
最佳答案
月排行榜 / 总排行榜
grf1973
2014-9-17 17:00
  1. Sub tt()
  2.     Dim f As Integer
  3.     Dim arr(1 To 10000, 1 To 1)
  4.     f = FreeFile
  5.     mypath = ThisWorkbook.Path
  6.     Open mypath & "\列表.txt" For Input As #f
  7.     Do While Not EOF(f)     '把文本内容全部读入数组arr
  8.         n = n + 1
  9.         Line Input #f, arr(n, 1)
  10.     Loop
  11.     Close #f
  12.    
  13.     ReDim brr(1 To n, 1 To 4)   '按每组数据取前三行，4列输出
  14.     For i = 1 To UBound(arr) - 3
  15.         a = arr(i, 1): b = arr(i + 1, 1)
  16.         If Len(a) = 1 And Len(b) > 1 Then          '判断每一组数据的起始位置
  17.             m = m + 1
  18.             If InStr(b, "(") > 0 Then c = Split(b, "(")(1): brr(m, 1) = Left(c, Len(c) - 1)      '版本号
  19.             brr(m, 2) = b: brr(m, 4) = arr(i + 3, 1)
  20.             d = arr(i + 2, 1): d1 = InStr(d, ":"): d2 = InStr(d, ",")
  21.             If d1 > 0 And d2 > 0 Then brr(m, 3) = Trim(Mid(d, d1 + 1, d2 - d1 - 1))       '文件大小
  22.             i = i + 3
  23.         End If
  24.     Next
  25.     Rows("2:10000").ClearContents
  26.     [a2].Resize(m, 4) = brr
  27. End Sub
复制代码
代码小改一下，请看附件。
excel

相关帖子
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
 楼主| 发表于 2014-9-17 15:33 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
附件在此

列表.rar

10.36 KB, 下载次数: 16
回复

使用道具 举报

 楼主| 发表于 2014-9-17 16:03 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
如果大家觉得多余的数据影响了操作，以下附件没有多余的数据

列表1.rar

6.04 KB, 下载次数: 2
回复

使用道具 举报

grf1973
发表于 2014-9-17 16:57 | 显示全部楼层
  1. Sub tt()
  2.     Dim f As Integer
  3.     Dim arr(1 To 10000, 1 To 1)
  4.     f = FreeFile
  5.     mypath = ThisWorkbook.Path
  6.     Open mypath & "\列表.txt" For Input As #f
  7.     Do While Not EOF(f)     '把文本内容全部读入数组arr
  8.         Line Input #f, a
  9.         If Len(a) > 0 Then
  10.             n = n + 1
  11.             arr(n, 1) = a
  12.         End If
  13.     Loop
  14.     Close #f
  15.    
  16.     ReDim brr(1 To n, 1 To 4)   '按每组数据取前三行，4列输出
  17.     For i = 1 To UBound(arr) - 3
  18.         a = arr(i, 1): b = arr(i + 1, 1)
  19.         If Len(a) = 1 And Len(b) > 1 Then          '判断每一组数据的起始位置
  20.             m = m + 1
  21.             If InStr(b, "(") > 0 Then c = Split(b, "(")(1): brr(m, 1) = Left(c, Len(c) - 1)      '版本号
  22.             brr(m, 2) = b: brr(m, 4) = arr(i + 3, 1)
  23.             d = arr(i + 2, 1): d1 = InStr(d, ":"): d2 = InStr(d, ",")
  24.             If d1 > 0 And d2 > 0 Then brr(m, 3) = Trim(Mid(d, d1 + 1, d2 - d1 - 1))       '文件大小
  25.             i = i + 3
  26.         End If
  27.     Next
  28.     Rows("2:10000").ClearContents
  29.     [a2].Resize(m, 4) = brr
  30. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2014-9-17 17:00 | 显示全部楼层    本楼为最佳答案   
  1. Sub tt()
  2.     Dim f As Integer
  3.     Dim arr(1 To 10000, 1 To 1)
  4.     f = FreeFile
  5.     mypath = ThisWorkbook.Path
  6.     Open mypath & "\列表.txt" For Input As #f
  7.     Do While Not EOF(f)     '把文本内容全部读入数组arr
  8.         n = n + 1
  9.         Line Input #f, arr(n, 1)
  10.     Loop
  11.     Close #f
  12.    
  13.     ReDim brr(1 To n, 1 To 4)   '按每组数据取前三行，4列输出
  14.     For i = 1 To UBound(arr) - 3
  15.         a = arr(i, 1): b = arr(i + 1, 1)
  16.         If Len(a) = 1 And Len(b) > 1 Then          '判断每一组数据的起始位置
  17.             m = m + 1
  18.             If InStr(b, "(") > 0 Then c = Split(b, "(")(1): brr(m, 1) = Left(c, Len(c) - 1)      '版本号
  19.             brr(m, 2) = b: brr(m, 4) = arr(i + 3, 1)
  20.             d = arr(i + 2, 1): d1 = InStr(d, ":"): d2 = InStr(d, ",")
  21.             If d1 > 0 And d2 > 0 Then brr(m, 3) = Trim(Mid(d, d1 + 1, d2 - d1 - 1))       '文件大小
  22.             i = i + 3
  23.         End If
  24.     Next
  25.     Rows("2:10000").ClearContents
  26.     [a2].Resize(m, 4) = brr
  27. End Sub
复制代码
代码小改一下，请看附件。

列表.rar

16.95 KB, 下载次数: 15

评分

参与人数 1 +1 收起 理由
qwwqExcel + 1 大侠太厉害了，辛苦你了，不然我得累死

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2014-9-21 14:35 | 显示全部楼层
grf1973 发表于 2014-9-17 17:00
代码小改一下，请看附件。

大侠你好，我做了个总表，和之前的表不同，把数据导入进去后每列位置排序都不同，我尝试过修改VBA，但没成功，我希望可以自己设置把对应的数据导入到A列或B列，而不是一定要从A列往后排列，还有导入列表信息后再导入地址信息时，地址信息根据对应的列表信息进行排列，表格和文件见附件
回复

使用道具 举报

 楼主| 发表于 2014-9-21 14:36 | 显示全部楼层
附件在此

文件夹.rar

47.92 KB, 下载次数: 10
回复

使用道具 举报

grf1973
发表于 2014-9-22 16:39 | 显示全部楼层
  1. Sub 导入()
  2.     Dim f As Integer
  3.     Dim arr(1 To 10000, 1 To 1)
  4.     f = FreeFile
  5.     mypath = ThisWorkbook.Path
  6.     Open mypath & "\列表.txt" For Input As #f
  7.     Do While Not EOF(f)     '读“列表”入数组arr
  8.         n = n + 1
  9.         Line Input #f, arr(n, 1)
  10.     Loop
  11.     Close #f
  12.    
  13.     ReDim brr(1 To n, 1 To 9)   '按每组数据取前三行，9列输出
  14.     For i = 1 To UBound(arr) - 3
  15.         a = arr(i, 1): b = arr(i + 1, 1)
  16.         If Len(a) = 1 And Len(b) > 1 Then          '判断每一组数据的起始位置
  17.             m = m + 1
  18.             If InStr(b, "(") > 0 Then c = Split(b, "(")(1): brr(m, 1) = Left(c, Len(c) - 1)      '版本号
  19.             brr(m, 3) = b         '产品名称
  20.             brr(m, 5) = arr(i + 2, 1)       '文件大小
  21.             brr(m, 9) = arr(i + 3, 1)        '描述
  22.             i = i + 3
  23.         End If
  24.     Next
  25.    
  26.    
  27.     Set d = CreateObject("scripting.dictionary")
  28.     Dim crr(1 To 10000, 1 To 2)
  29.     Open mypath & "\地址.txt" For Input As #f
  30.     n = 0
  31.     Do While Not EOF(f)     '读入“地址”入数组crr
  32.         Line Input #f, a
  33.         aa = LCase(a)
  34.         If InStr(aa, "http") > 0 And InStr(aa, ".exe") > 0 Then
  35.             a1 = InStr(aa, "http"): a2 = InStr(aa, ".exe")
  36.             If a2 > a1 Then a = Mid(a, a1, a2 + 3 - a1 + 1)   '下载地址：http:\\。。。。。.exe
  37.             br = Split(a, "/"): b = br(UBound(br))
  38.             b = Split(b, "_")(0) & ".exe"        '文件名称：。。。。。.exe
  39.             If Not d.exists(b) Then
  40.                 n = n + 1
  41.                 crr(n, 1) = b             '文件名称
  42.                 crr(n, 2) = a            '下载地址
  43.                 d(b) = ""
  44.             End If
  45.         End If
  46.     Loop
  47.     Close #f
  48.    
  49.    
  50.     For i = 1 To m
  51.         bbh = LCase(Trim(brr(i, 1)))   '版本号
  52.         If Len(bbh) > 0 Then
  53.             For j = 1 To n
  54.                 wjmc = LCase(crr(j, 1))         '文件名称
  55.                 If InStr(wjmc, bbh) > 0 Then          '文件名称中含有版本号的筛选出来
  56.                     brr(i, 2) = wjmc      '文件名称
  57.                     brr(i, 4) = crr(j, 2)       '下载地址
  58.                 End If
  59.             Next
  60.         End If
  61.     Next
  62.    
  63.     Rows("4:10000").ClearContents
  64.     [b4].Resize(m, 9) = brr             '数据输出
  65. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2014-9-22 16:40 | 显示全部楼层
请看附件。

文件夹.rar

75.65 KB, 下载次数: 5
回复

使用道具 举报

 楼主| 发表于 2014-9-23 00:30 | 显示全部楼层
grf1973 发表于 2014-9-22 16:40
请看附件。

大侠你太厉害了，好感动哦，谢谢你一直为我解决问题，精神可嘉！
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-26 08:11 , Processed in 0.319324 second(s), 16 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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