求助更高效的遍历汇总

Ericcccccc · 发表于 2020-3-12 15:29

本帖最后由 Ericcccccc 于 2020-3-12 17:33 编辑

求助各位大神，我用下面的代码获取test文件夹目录下所有html文件内容放到sheets中，但感觉效率好慢，等待的时间有点长，请问可以用其他方法优化吗？

Dim i As Long
Dim f As String                      '定义f读取一个文件夹下所有文件的文件名信息
Dim full As String                   '定义full用来存放文件夹下某个文件的URL
Dim ws As Worksheet
Set ws = Worksheets("sheet1")          '存放读取结果
i = 1
f = Dir("C:\Users\excelhome\Desktop\test\")       '获取文件夹下的文件名
Do While f <> ""                      '读取一个文件夹下所有文件
full = "C:\Users\excelhome\Desktop\test\" & f
Open full For Input As #1          '把full写入EXCEL
      Do While Not EOF(1)          'full不为空
         Line Input #1, s
         ws.Cells(i, 1) = s
         i = i + 1                '赋值
      Loop

Close #1

i = i + 2                         '下一文件数据的读取空两行
f = Dir                            '读取下一个txt文件

Loop

MsgBox "完成"

Ericcccccc · 发表于 2020-3-12 16:16

消灭0回复

鄂龙蒙 · 发表于 2020-3-12 16:25

读入数组后再写入速度会大幅提升

Ericcccccc · 发表于 2020-3-12 16:33

鄂龙蒙发表于 2020-3-12 16:25
读入数组后再写入速度会大幅提升

能帮忙写下吗

shenjianrong163 · 发表于 2020-3-12 16:38

有附件效果更好。

Ericcccccc · 发表于 2020-3-12 17:33

shenjianrong163 发表于 2020-3-12 16:38
有附件效果更好。

已上传，，，真，，真的是太慢了

shenjianrong163 · 发表于 2020-3-12 19:52

Ericcccccc 发表于 2020-3-12 17:33
已上传，，，真，，真的是太慢了

Sub test()
Application.ScreenUpdating = False
Dim i
i = 1
Set ws = Worksheets("测试") '存放读取结果
Set fso = CreateObject("Scripting.FileSystemObject")
ws.UsedRange.ClearContents '清空数据
For Each f In fso.Getfolder(ThisWorkbook.Path).Files
If InStr(f.Name, ThisWorkbook.Name) = 0 Then
Open f For Input As #1 '把f写入EXCEL
Do While Not EOF(1) 'f不为空
Line Input #1, s
ws.Cells(i, 1) = s
i = i + 1 '空两行后再写入下一个文件
Loop
Close #1
i = i + 2
End If
Next
Application.ScreenUpdating = True
MsgBox "完成"
End Sub

复制代码

shenjianrong163 · 发表于 2020-3-12 19:53

请参考附件：

测试2.rar (35.18 KB, 下载次数: 9)

Ericcccccc · 发表于 2020-3-12 23:36

shenjianrong163 发表于 2020-3-12 19:52

真的是，从自行车变成高铁了，感谢感谢~

		自动登录	找回密码
密码			免费注册

[求助] 求助更高效的遍历汇总