Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 4389|回复: 10

[已解决]excel导入文本文档里的所需信息到指定位置

[复制链接]
发表于 2014-9-17 22:43 | 显示全部楼层 |阅读模式
由于文本文档的信息比较多,请教下大侠们如何用VBA实现。
将文本里的exe格式的链接地址导入到excel指定位置,其它格式的链接不要,并且把exe格式
的链接地址中的最后一个斜杠和下划线里的文件名导入到excel指定位置中并在文件名末尾添加“.exe”


附件如下:
最佳答案
2014-9-18 14:21
用字典试了下去重,果然少了很多,我把相同的exe文件去掉了。
  1. Sub tt()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     Dim f As Integer
  4.     Dim arr(1 To 10000, 1 To 2)
  5.     f = FreeFile
  6.     mypath = ThisWorkbook.Path
  7.     Open mypath & "\地址.txt" For Input As #f
  8.     Do While Not EOF(f)     '把文本内容全部读入数组arr
  9.         Line Input #f, a
  10.         aa = LCase(a)
  11.         If InStr(aa, "http") > 0 And InStr(aa, ".exe") > 0 Then
  12.             a1 = InStr(aa, "http"): a2 = InStr(aa, ".exe")
  13.             If a2 > a1 Then a = Mid(a, a1, a2 + 3 - a1 + 1)   '下载地址:http:\\。。。。。.exe
  14.             br = Split(a, "/"): b = br(UBound(br))
  15.             b = Split(b, "_")(0) & ".exe"        '文件名称:。。。。。.exe
  16.             If Not d.exists(b) Then
  17.                 n = n + 1
  18.                 arr(n, 1) = b
  19.                 arr(n, 2) = a
  20.                 d(b) = ""
  21.             End If
  22.         End If
  23.     Loop
  24.     Close #f
  25.    
  26.     With ActiveSheet
  27.         .Rows("2:10000").ClearContents
  28.         .[a2].Resize(n, 2) = arr
  29.     End With
  30. End Sub
复制代码
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
 楼主| 发表于 2014-9-17 22:44 | 显示全部楼层
附件在此哦
QQ截图20140917224243.png

地址.rar

34.43 KB, 下载次数: 7

回复

使用道具 举报

发表于 2014-9-18 11:44 | 显示全部楼层
  1. Sub tt()
  2.     Dim f As Integer
  3.     Dim arr(1 To 10000, 1 To 2)
  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.         aa = LCase(a)
  10.         If InStr(aa, "http") > 0 And InStr(aa, ".exe") > 0 Then
  11.             a1 = InStr(aa, "http"): a2 = InStr(aa, ".exe")
  12.             If a2 > a1 Then a = Mid(a, a1, a2 + 3 - a1 + 1)   '下载地址:http:\\。。。。。.exe
  13.             br = Split(a, "/"): b = br(UBound(br))
  14.             b1 = InStr(LCase(b), ".exe"): b = Left(b, b1 + 3)        '文件名称:。。。。。.exe
  15.             n = n + 1
  16.             arr(n, 1) = b
  17.             arr(n, 2) = a
  18.         End If
  19.     Loop
  20.     Close #f
  21.    
  22.     With ActiveSheet
  23.         .Rows("2:10000").ClearContents
  24.         .[a2].Resize(n, 2) = arr
  25.     End With
  26. End Sub

复制代码
回复

使用道具 举报

发表于 2014-9-18 11:45 | 显示全部楼层
请看附件。

地址.rar

40.05 KB, 下载次数: 2

回复

使用道具 举报

 楼主| 发表于 2014-9-18 11:57 | 显示全部楼层
又是这位大侠,大侠你太牛了!有没有办法让好几个重复的链接只复制其中一个过去,还有让文件名里红色部分不复制进去,见附件
回复

使用道具 举报

 楼主| 发表于 2014-9-18 11:58 | 显示全部楼层
附件在此
QQ截图20140918115411.png
回复

使用道具 举报

 楼主| 发表于 2014-9-18 11:59 | 显示全部楼层
grf1973 发表于 2014-9-18 11:45
请看附件。

大侠你太牛了!有没有办法让好几个重复的链接只复制其中一个过去,还有让文件名里红色部分不复制进去,见附件图片
回复

使用道具 举报

发表于 2014-9-18 14:17 | 显示全部楼层
  1. Sub tt()
  2.     Dim f As Integer
  3.     Dim arr(1 To 10000, 1 To 2)
  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.         aa = LCase(a)
  10.         If InStr(aa, "http") > 0 And InStr(aa, ".exe") > 0 Then
  11.             a1 = InStr(aa, "http"): a2 = InStr(aa, ".exe")
  12.             If a2 > a1 Then a = Mid(a, a1, a2 + 3 - a1 + 1)   '下载地址:http:\\。。。。。.exe
  13.             br = Split(a, "/"): b = br(UBound(br))
  14.             b = Split(b, "_")(0) & ".exe"        '文件名称:。。。。。.exe
  15.             n = n + 1
  16.             arr(n, 1) = b
  17.             arr(n, 2) = a
  18.         End If
  19.     Loop
  20.     Close #f
  21.    
  22.     With ActiveSheet
  23.         .Rows("2:10000").ClearContents
  24.         .[a2].Resize(n, 2) = arr
  25.     End With
  26. End Sub
复制代码
重复的链接是什么意思,没发现有重复的啊
回复

使用道具 举报

发表于 2014-9-18 14:21 | 显示全部楼层    本楼为最佳答案   
用字典试了下去重,果然少了很多,我把相同的exe文件去掉了。
  1. Sub tt()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     Dim f As Integer
  4.     Dim arr(1 To 10000, 1 To 2)
  5.     f = FreeFile
  6.     mypath = ThisWorkbook.Path
  7.     Open mypath & "\地址.txt" For Input As #f
  8.     Do While Not EOF(f)     '把文本内容全部读入数组arr
  9.         Line Input #f, a
  10.         aa = LCase(a)
  11.         If InStr(aa, "http") > 0 And InStr(aa, ".exe") > 0 Then
  12.             a1 = InStr(aa, "http"): a2 = InStr(aa, ".exe")
  13.             If a2 > a1 Then a = Mid(a, a1, a2 + 3 - a1 + 1)   '下载地址:http:\\。。。。。.exe
  14.             br = Split(a, "/"): b = br(UBound(br))
  15.             b = Split(b, "_")(0) & ".exe"        '文件名称:。。。。。.exe
  16.             If Not d.exists(b) Then
  17.                 n = n + 1
  18.                 arr(n, 1) = b
  19.                 arr(n, 2) = a
  20.                 d(b) = ""
  21.             End If
  22.         End If
  23.     Loop
  24.     Close #f
  25.    
  26.     With ActiveSheet
  27.         .Rows("2:10000").ClearContents
  28.         .[a2].Resize(n, 2) = arr
  29.     End With
  30. End Sub
复制代码
回复

使用道具 举报

发表于 2014-9-18 14:23 | 显示全部楼层
这下应该没问题了吧。。。。。。。

地址.rar

39.69 KB, 下载次数: 3

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 04:37 , Processed in 0.530054 second(s), 12 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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