Question

通过VBA将多个txt文件导入Excel时，我遇到了与.Refresh BackgroundQuery:=False相关的内存不足警告。正好在723个正确导入的文本文件中弹出错误。

这是我使用的VBA代码：

Sub Sample()
Dim myfiles
Dim i As Integer

myfiles = Application.GetOpenFilename(filefilter:="Text files (*.txt), *.txt", MultiSelect:=True)

If Not IsEmpty(myfiles) Then
For i = LBound(myfiles) To UBound(myfiles)
     With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & myfiles(i), Destination:=Range("A" & Rows.Count).End(xlUp).Offset(1, 0))
        .Name = "Sample"
        .FieldNames = False
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Next i
Else
MsgBox "No File Selected"
End If

End Sub

我该如何解决这个问题？

Answer 1

我认为这与缓存大小，页面大小和每页记录有关。如果您尝试以下代码 objRecordset.Open“SELECT * FROM”＆amp; CSV_FILE，objConnection，adOpenStatic，adLockOptimistic，adCmdText

If Not objRecordset.EOF Then
intpagecount = objRecordset.PageCount
MsgBox intpagecount
MsgBox objRecordset.PageSize
Debug.Print objRecordset.CacheSize

结束如果

在大型CSV文件上，您会发现VBA始终在每页末尾显示“内存已满”错误。在这种情况下，每页有10条记录，50585页。果然，我在每页10 * 50585 = 505850条记录中得到满内存。

Answer 2

您可能在工作簿中有很多连接，因为您不断添加它们，但之后不会删除它们。

尝试此操作，但首先运行Sub CleanUpQT()作为一次。此外，某些范围不完全合格，如果在代码运行时更改工作表，则会导致问题。使用Set ws = Sheet1设置您希望此操作的工作表 - 其中Sheet1是代号或类似名称。

Option Explicit

Sub Sample()
Dim myfiles As Variant
Dim i As Integer
Dim temp_qt As QueryTable
Dim ws As Worksheet

myfiles = Application.GetOpenFilename(filefilter:="Text files (*.txt), *.txt", MultiSelect:=True)

If Not IsEmpty(myfiles) Then
    Set ws = Sheet1
    For i = LBound(myfiles) To UBound(myfiles)

        Set temp_qt = ws.QueryTables.Add(Connection:= _
            "TEXT;" & myfiles(i), Destination:=ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0))

         With temp_qt
            .Name = "Sample"
            .FieldNames = False
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = True
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
    Next i
    Set temp_qt = Nothing
    CleanUpQT
Else
MsgBox "No File Selected"
End If

End Sub

Sub CleanUpQT()
Dim connCount As Long
Dim i As Long

    connCount = ThisWorkbook.Connections.Count
    For i = 1 To connCount
        ThisWorkbook.Connections.Item(i).Delete
    Next i

End Sub

使用VBA导入文本文件时出现Excel内存不足警告

2 个答案: