arrays - Excel VBA 从 Txt 文件中提取特定的开始和长度

Question

我有一个运行没有失败的 Excel 2007 代码。

但它非常慢 - 让我的电脑在运行的 1-2 分钟内没有响应。

这些文件大约有 14,000 kb - 所以不会太大。

如果可能的话，我希望有人告诉我我可以做些什么来让它运行而不会导致我的计算机挂起。提前致谢。

Sub ReadFileIntoExcel()

Dim fPath As String
Const fsoForReading = 1
Dim readlength As Integer
Dim readstart As Integer
readlength = Worksheets("READFILE").Cells(1, "E").Value
readstart = Worksheets("READFILE").Cells(1, "D").Value
fPath = Worksheets("READFILE").Cells(1, "C").Value

Dim objFSO As Object
Dim objTextStream As Object, txt, allread, rw


Set objFSO = CreateObject("scripting.filesystemobject")
If objFSO.FileExists(fPath) Then
Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
rw = 1

Do Until objTextStream.AtEndOfStream
    txt = objTextStream.ReadLine
    allread = Trim(Mid(txt, readstart, readlength))
    With ActiveWorkbook.Sheets("READFILE").Cells(rw, 7).Resize(1, 1)
        .NumberFormat = "@" 'format cells as text
        .Value = Array(allread)
    End With
    rw = rw + 1
Loop

objTextStream.Close
Set objTextStream = Nothing
Set objFSO = Nothing
Exit Sub

Answer 1

我更新了您的代码以使用数组而不是逐个单元格写入，它立即运行

进行的优化

避免单元格范围循环，尤其是逐个单元格地编写。请改用数组。这是大的

Resize(1,1)什么都不做，因为它将单元格保持为单个单元格

Long比 Integer 更有效

使用字符串函数 Mid$而不是他们较慢的变体替代品Mid

allread变量是不必要的中间步骤

对对象使用变量名(即 ws 用于工作表)，防止更长的引用

代码

Sub ReadFileIntoExcel()

Dim fPath As String
Dim ws As Worksheet
Const fsoForReading = 1
Dim readlength As Long
Dim readstart As Long
Dim rw as Long
Dim X()

Set ws = Worksheets("READFILE")
readlength = ws.Cells(1, "E").Value
readstart = ws.Cells(1, "D").Value
fPath = ws.Cells(1, "C").Value

Dim objFSO As Object
Dim objTextStream As Object


Set objFSO = CreateObject("scripting.filesystemobject")
If objFSO.FileExists(fPath) Then
Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
rw = 1

ReDim X(1 To 1, 1 To 1000)

Do Until objTextStream.AtEndOfStream
    txt = objTextStream.ReadLine
    If rw Mod 1000 = 0 Then ReDim Preserve X(1 To 1, 1 To UBound(X, 2) + 1000)
    X(1, rw) = Trim$(Mid$(txt, readstart, readlength))
    rw = rw + 1
Loop

ws.[G1].Resize(UBound(X, 2), 1) = Application.Transpose(X)
ws.Columns("G").NumberFormat = "@"

objTextStream.Close
Set objTextStream = Nothing
Set objFSO = Nothing
Exit Sub
End If
End Sub